Merge branch 'master' into irc

Makefile

@@ -1,4 +1,5 @@
 CC = gcc
+CPP = g++
 AR = ar
 LD = ld
 
@@ -10,14 +11,15 @@ VERSION = 0.92
 BUNDLE = Factor.app
 LIBPATH = -L/usr/X11R6/lib
 CFLAGS = -Wall
-FFI_TEST_CFLAGS = -fPIC
 
 ifdef DEBUG
-	CFLAGS += -g
+	CFLAGS += -g -DFACTOR_DEBUG
 else
-	CFLAGS += -O3 $(SITE_CFLAGS)
+	CFLAGS += -O3
 endif
 
+CFLAGS += $(SITE_CFLAGS)
+
 ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
 
 ifdef CONFIG
@@ -26,25 +28,36 @@ endif
 
 DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/alien.o \
+	vm/arrays.o \
 	vm/bignum.o \
+	vm/booleans.o \
+	vm/byte_arrays.o \
 	vm/callstack.o \
 	vm/code_block.o \
 	vm/code_gc.o \
 	vm/code_heap.o \
+	vm/contexts.o \
 	vm/data_gc.o \
 	vm/data_heap.o \
 	vm/debug.o \
+	vm/dispatch.o \
 	vm/errors.o \
 	vm/factor.o \
 	vm/image.o \
+	vm/inline_cache.o \
 	vm/io.o \
+	vm/jit.o \
+	vm/local_roots.o \
 	vm/math.o \
 	vm/primitives.o \
 	vm/profiler.o \
 	vm/quotations.o \
 	vm/run.o \
-	vm/types.o \
+	vm/strings.o \
-	vm/utilities.o
+	vm/tuples.o \
+	vm/utilities.o \
+	vm/words.o \
+	vm/write_barrier.o
 
 EXE_OBJS = $(PLAF_EXE_OBJS)
 
@@ -152,12 +165,12 @@ macosx.app: factor
 
 $(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
 	$(LINKER) $(ENGINE) $(DLL_OBJS)
-	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
 
 $(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
 	$(LINKER) $(ENGINE) $(DLL_OBJS)
-	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
 
 $(TEST_LIBRARY): vm/ffi_test.o
@@ -165,7 +178,13 @@ $(TEST_LIBRARY): vm/ffi_test.o
 
 clean:
 	rm -f vm/*.o
-	rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
+	rm -f factor.dll
+	rm -f libfactor.*
+	rm -f libfactor-ffi-test.*
+	rm -f Factor.app/Contents/Frameworks/libfactor.dylib
+
+tags:
+	etags vm/*.{cpp,hpp,mm,S,c}
 
 vm/resources.o:
 	$(WINDRES) vm/factor.rs vm/resources.o
@@ -176,10 +195,15 @@ vm/ffi_test.o: vm/ffi_test.c
 .c.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
 
+.cpp.o:
+	$(CPP) -c $(CFLAGS) -o $@ $<
+
 .S.o:
 	$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
 
-.m.o:
+.mm.o:
-	$(CC) -c $(CFLAGS) -o $@ $<
+	$(CPP) -c $(CFLAGS) -o $@ $<
 
-.PHONY: factor
+.PHONY: factor tags clean
+
+.SUFFIXES: .mm

README.txt

@@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself.
 
 * Compiling the Factor VM
 
-The Factor runtime is written in GNU C99, and is built with GNU make and
-gcc.
-
 Factor supports various platforms. For an up-to-date list, see
 <http://factorcode.org>.
 
-Factor requires gcc 3.4 or later.
+The Factor VM is written in C++ and uses GNU extensions. When compiling
-
+with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
-On x86, Factor /will not/ build using gcc 3.3 or earlier.
+uses std::tr1::unordered_map which is shipped as part of GCC.
-
-If you are using gcc 4.3, you might get an unusable Factor binary unless
-you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
-arguments for make.
 
 Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
 
 * Bootstrapping the Factor image
 
-Once you have compiled the Factor runtime, you must bootstrap the Factor
+Once you have compiled the Factor VM, you must bootstrap the Factor
 system using the image that corresponds to your CPU architecture.
 
 Boot images can be obtained from <http://factorcode.org/images/latest/>.
@@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter:
 
 Then bootstrap with the following switches:
 
-  ./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
+  ./factor -i=boot.<cpu>.image -ui-backend=x11
 
 Now if $DISPLAY is set, running ./factor will start the UI.
 
@@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener:
 The Factor source tree is organized as follows:
 
   build-support/ - scripts used for compiling Factor
-  vm/ - sources for the Factor VM, written in C
+  vm/ - Factor VM
   core/ - Factor core library
   basis/ - Factor basis library, compiler, tools
   extra/ - more libraries and applications

basis/alarms/alarms.factor

@@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
     ] when* ;
 
 : init-alarms ( -- )
-    alarms global [ cancel-alarms <min-heap> ] change-at
+    alarms [ cancel-alarms <min-heap> ] change-global
     [ alarm-thread-loop t ] "Alarms" spawn-server
     alarm-thread set-global ;
 

basis/alien/arrays/arrays.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays alien.c-types alien.structs
+USING: alien alien.strings alien.c-types alien.accessors alien.structs
-sequences math kernel namespaces fry libc cpu.architecture ;
+arrays words sequences math kernel namespaces fry libc cpu.architecture
+io.encodings.utf8 io.encodings.utf16n ;
 IN: alien.arrays
 
 UNION: value-type array struct-type ;
@@ -38,3 +39,61 @@ M: value-type c-type-getter
 M: value-type c-type-setter ( type -- quot )
     [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
     '[ @ swap @ _ memcpy ] ;
+
+PREDICATE: string-type < pair
+    first2 [ "char*" = ] [ word? ] bi* and ;
+
+M: string-type c-type ;
+
+M: string-type c-type-class
+    drop object ;
+
+M: string-type heap-size
+    drop "void*" heap-size ;
+
+M: string-type c-type-align
+    drop "void*" c-type-align ;
+
+M: string-type c-type-stack-align?
+    drop "void*" c-type-stack-align? ;
+
+M: string-type unbox-parameter
+    drop "void*" unbox-parameter ;
+
+M: string-type unbox-return
+    drop "void*" unbox-return ;
+
+M: string-type box-parameter
+    drop "void*" box-parameter ;
+
+M: string-type box-return
+    drop "void*" box-return ;
+
+M: string-type stack-size
+    drop "void*" stack-size ;
+
+M: string-type c-type-reg-class
+    drop int-regs ;
+
+M: string-type c-type-boxer
+    drop "void*" c-type-boxer ;
+
+M: string-type c-type-unboxer
+    drop "void*" c-type-unboxer ;
+
+M: string-type c-type-boxer-quot
+    second '[ _ alien>string ] ;
+
+M: string-type c-type-unboxer-quot
+    second '[ _ string>alien ] ;
+
+M: string-type c-type-getter
+    drop [ alien-cell ] ;
+
+M: string-type c-type-setter
+    drop [ set-alien-cell ] ;
+
+{ "char*" utf8 } "char*" typedef
+"char*" "uchar*" typedef
+{ "char*" utf16n } "wchar_t*" typedef
+

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

@@ -1,7 +1,7 @@
 IN: alien.c-types
 USING: alien help.syntax help.markup libc kernel.private
-byte-arrays math strings hashtables alien.syntax
+byte-arrays math strings hashtables alien.syntax alien.strings sequences
-debugger destructors ;
+io.encodings.string debugger destructors ;
 
 HELP: <c-type>
 { $values { "type" hashtable } }
@@ -114,6 +114,38 @@ HELP: define-out
 { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
 { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
 
+{ string>alien alien>string malloc-string } related-words
+
+HELP: malloc-string
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
+{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if one of the following conditions occurs:"
+    { $list
+        "the string contains null code points"
+        "the string contains characters not representable using the encoding specified"
+        "memory allocation fails"
+    }
+} ;
+
+ARTICLE: "c-strings" "C strings"
+"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
+$nl
+"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
+$nl
+"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+$nl
+"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
+$nl
+"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
+{ $subsection string>alien }
+{ $subsection malloc-string }
+"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
+$nl
+"A word to read strings from arbitrary addresses:"
+{ $subsection alien>string }
+"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
+
 ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
 "The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
 $nl

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

@@ -2,9 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces make parser sequences strings words assocs splitting
-math.parser cpu.architecture alien alien.accessors quotations
+math.parser cpu.architecture alien alien.accessors alien.strings
-layouts system compiler.units io.files io.encodings.binary
+quotations layouts system compiler.units io io.files
-accessors combinators effects continuations fry classes ;
+io.encodings.binary io.streams.memory accessors combinators effects
+continuations fry classes ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -213,6 +214,15 @@ M: f byte-length drop 0 ;
 : memory>byte-array ( alien len -- byte-array )
     [ nip (byte-array) dup ] 2keep memcpy ;
 
+: malloc-string ( string encoding -- alien )
+    string>alien malloc-byte-array ;
+
+M: memory-stream stream-read
+    [
+        [ index>> ] [ alien>> ] bi <displaced-alien>
+        swap memory>byte-array
+    ] [ [ + ] change-index drop ] 2bi ;
+
 : byte-array>memory ( byte-array base -- )
     swap dup byte-length memcpy ;
 
@@ -399,10 +409,10 @@ CONSTANT: primitive-types
     "uchar" define-primitive-type
 
     <c-type>
-        [ alien-unsigned-4 zero? not ] >>getter
+        [ alien-unsigned-1 zero? not ] >>getter
-        [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
+        [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
-        4 >>size
+        1 >>size
-        4 >>align
+        1 >>align
         "box_boolean" >>boxer
         "to_boolean" >>unboxer
     "bool" define-primitive-type

basis/alien/libraries/libraries-docs.factor

@@ -15,7 +15,7 @@ HELP: libraries
 { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
 
 HELP: library
-{ $values { "name" "a string" } { "library" "a hashtable" } }
+{ $values { "name" "a string" } { "library" assoc } }
 { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
     { $list
         { { $snippet "name" } " - the full path of the C library binary" }

basis/alien/libraries/libraries.factor

@@ -1,8 +1,12 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien assocs io.backend kernel namespaces ;
+USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
 IN: alien.libraries
 
+: dlopen ( path -- dll ) native-string>alien (dlopen) ;
+
+: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
+
 SYMBOL: libraries
 
 libraries [ H{ } clone ] initialize

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

@@ -15,7 +15,7 @@ IN: alien.remote-control
     "void" { "long" } "cdecl" [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )
-    dup optimized>> [ execute ] [ drop f ] if ; inline
+    dup optimized? [ execute ] [ drop f ] if ; inline
 
 : init-remote-control ( -- )
     \ eval-callback ?callback 16 setenv

basis/alien/strings/strings-docs.factor

@@ -1,52 +0,0 @@
-USING: help.markup help.syntax strings byte-arrays alien libc
-debugger io.encodings.string sequences ;
-IN: alien.strings
-
-HELP: string>alien
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
-{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
-{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
-
-{ string>alien alien>string malloc-string } related-words
-
-HELP: alien>string
-{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
-{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
-
-HELP: malloc-string
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
-{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if one of the following conditions occurs:"
-    { $list
-        "the string contains null code points"
-        "the string contains characters not representable using the encoding specified"
-        "memory allocation fails"
-    }
-} ;
-
-HELP: string>symbol
-{ $values { "str" string } { "alien" alien } }
-{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
-$nl
-"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
-
-ARTICLE: "c-strings" "C strings"
-"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
-$nl
-"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
-$nl
-"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
-$nl
-"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
-$nl
-"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
-{ $subsection string>alien }
-{ $subsection malloc-string }
-"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
-$nl
-"A word to read strings from arbitrary addresses:"
-{ $subsection alien>string }
-"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
-
-ABOUT: "c-strings"

basis/alien/strings/strings.factor

@@ -1,109 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays sequences kernel accessors math alien.accessors
-alien.c-types byte-arrays words io io.encodings
-io.encodings.utf8 io.streams.byte-array io.streams.memory system
-alien strings cpu.architecture fry vocabs.loader combinators ;
-IN: alien.strings
-
-GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
-
-M: c-ptr alien>string
-    [ <memory-stream> ] [ <decoder> ] bi*
-    "\0" swap stream-read-until drop ;
-
-M: f alien>string
-    drop ;
-
-ERROR: invalid-c-string string ;
-
-: check-string ( string -- )
-    0 over memq? [ invalid-c-string ] [ drop ] if ;
-
-GENERIC# string>alien 1 ( string encoding -- byte-array )
-
-M: c-ptr string>alien drop ;
-
-M: string string>alien
-    over check-string
-    <byte-writer>
-    [ stream-write ]
-    [ 0 swap stream-write1 ]
-    [ stream>> >byte-array ]
-    tri ;
-
-: malloc-string ( string encoding -- alien )
-    string>alien malloc-byte-array ;
-
-PREDICATE: string-type < pair
-    first2 [ "char*" = ] [ word? ] bi* and ;
-
-M: string-type c-type ;
-
-M: string-type c-type-class
-    drop object ;
-
-M: string-type heap-size
-    drop "void*" heap-size ;
-
-M: string-type c-type-align
-    drop "void*" c-type-align ;
-
-M: string-type c-type-stack-align?
-    drop "void*" c-type-stack-align? ;
-
-M: string-type unbox-parameter
-    drop "void*" unbox-parameter ;
-
-M: string-type unbox-return
-    drop "void*" unbox-return ;
-
-M: string-type box-parameter
-    drop "void*" box-parameter ;
-
-M: string-type box-return
-    drop "void*" box-return ;
-
-M: string-type stack-size
-    drop "void*" stack-size ;
-
-M: string-type c-type-reg-class
-    drop int-regs ;
-
-M: string-type c-type-boxer
-    drop "void*" c-type-boxer ;
-
-M: string-type c-type-unboxer
-    drop "void*" c-type-unboxer ;
-
-M: string-type c-type-boxer-quot
-    second '[ _ alien>string ] ;
-
-M: string-type c-type-unboxer-quot
-    second '[ _ string>alien ] ;
-
-M: string-type c-type-getter
-    drop [ alien-cell ] ;
-
-M: string-type c-type-setter
-    drop [ set-alien-cell ] ;
-
-HOOK: alien>native-string os ( alien -- string )
-
-HOOK: native-string>alien os ( string -- alien )
-
-: dll-path ( dll -- string )
-    path>> alien>native-string ;
-
-: string>symbol ( str -- alien )
-    dup string?
-    [ native-string>alien ]
-    [ [ native-string>alien ] map ] if ;
-
-{ "char*" utf8 } "char*" typedef
-"char*" "uchar*" typedef
-
-{
-    { [ os windows? ] [ "alien.strings.windows" require ] }
-    { [ os unix? ] [ "alien.strings.unix" require ] }
-} cond

basis/alien/strings/unix/summary.txt

@@ -1 +0,0 @@
-Default string encoding on Unix

basis/alien/strings/unix/unix.factor

@@ -1,8 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.strings io.encodings.utf8 system ;
-IN: alien.strings.unix
-
-M: unix alien>native-string utf8 alien>string ;
-
-M: unix native-string>alien utf8 string>alien ;

basis/alien/strings/windows/summary.txt

@@ -1 +0,0 @@
-Default string encoding on Windows

basis/alien/strings/windows/windows.factor

@@ -1,13 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.strings alien.c-types io.encodings.utf8
-io.encodings.utf16n system ;
-IN: alien.strings.windows
-
-M: windows alien>native-string utf16n alien>string ;
-
-M: wince native-string>alien utf16n string>alien ;
-
-M: winnt native-string>alien utf8 string>alien ;
-
-{ "char*" utf16n } "wchar_t*" typedef

basis/bootstrap/compiler/compiler.factor

@@ -5,7 +5,7 @@ sequences namespaces parser kernel kernel.private classes
 classes.private arrays hashtables vectors classes.tuple sbufs
 hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words command-line vocabs io
-io.encodings.string libc splitting math.parser
+io.encodings.string libc splitting math.parser memory
 compiler.units math.order compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.optimizer ;
 IN: bootstrap.compiler
@@ -23,10 +23,13 @@ IN: bootstrap.compiler
 
 "cpu." cpu name>> append require
 
-enable-compiler
+enable-optimizer
+
+! Push all tuple layouts to tenured space to improve method caching
+gc
 
 : compile-unoptimized ( words -- )
-    [ optimized>> not ] filter compile ;
+    [ optimized? not ] filter compile ;
 
 nl
 "Compiling..." write flush
@@ -38,7 +41,7 @@ nl
 ! which are also quick to compile are replaced by
 ! compiled definitions as soon as possible.
 {
-    roll -roll declare not
+    not
 
     array? hashtable? vector?
     tuple? sbuf? tombstone?

basis/bootstrap/image/image.factor

@@ -3,14 +3,13 @@
 USING: alien arrays byte-arrays generic assocs hashtables assocs
 hashtables.private io io.binary io.files io.encodings.binary
 io.pathnames kernel kernel.private math namespaces make parser
-prettyprint sequences sequences.private strings sbufs
+prettyprint sequences sequences.private strings sbufs vectors words
-vectors words quotations assocs system layouts splitting
+quotations assocs system layouts splitting grouping growable classes
-grouping growable classes classes.builtin classes.tuple
+classes.builtin classes.tuple classes.tuple.private vocabs
-classes.tuple.private words.private vocabs
+vocabs.loader source-files definitions debugger quotations.private
-vocabs.loader source-files definitions debugger
+sequences.private combinators math.order math.private accessors
-quotations.private sequences.private combinators
+slots.private generic.single.private compiler.units compiler.constants
-math.order math.private accessors
+fry bootstrap.image.syntax ;
-slots.private compiler.units fry ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
@@ -53,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
 
 M: integer (eql?) = ;
 
+M: float (eql?)
+    over float? [ fp-bitwise= ] [ 2drop f ] if ;
+
 M: sequence (eql?)
     over sequence? [
         2dup [ length ] bi@ =
@@ -94,13 +96,25 @@ CONSTANT: -1-offset             9
 
 SYMBOL: sub-primitives
 
-: make-jit ( quot rc rt offset -- quad )
+SYMBOL: jit-relocations
-    [ [ call( -- ) ] { } make ] 3dip 4array ;
 
-: jit-define ( quot rc rt offset name -- )
+: compute-offset ( rc -- offset )
+    [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
+
+: jit-rel ( rc rt -- )
+    over compute-offset 3array jit-relocations get push-all ;
+
+: make-jit ( quot -- jit-data )
+    [
+        V{ } clone jit-relocations set
+        call( -- )
+        jit-relocations get >array
+    ] B{ } make prefix ;
+
+: jit-define ( quot name -- )
     [ make-jit ] dip set ;
 
-: define-sub-primitive ( quot rc rt offset word -- )
+: define-sub-primitive ( quot word -- )
     [ make-jit ] dip sub-primitives get set-at ;
 
 ! The image being constructed; a vector of word-size integers
@@ -112,72 +126,59 @@ SYMBOL: big-endian
 ! Bootstrap architecture name
 SYMBOL: architecture
 
-! Bootstrap global namesapce
+RESET
-SYMBOL: bootstrap-global
 
 ! Boot quotation, set in stage1.factor
-SYMBOL: bootstrap-boot-quot
+USERENV: bootstrap-boot-quot 20
+
+! Bootstrap global namesapce
+USERENV: bootstrap-global 21
 
 ! JIT parameters
-SYMBOL: jit-code-format
+USERENV: jit-prolog 23
-SYMBOL: jit-prolog
+USERENV: jit-primitive-word 24
-SYMBOL: jit-primitive-word
+USERENV: jit-primitive 25
-SYMBOL: jit-primitive
+USERENV: jit-word-jump 26
-SYMBOL: jit-word-jump
+USERENV: jit-word-call 27
-SYMBOL: jit-word-call
+USERENV: jit-word-special 28
-SYMBOL: jit-push-immediate
+USERENV: jit-if-word 29
-SYMBOL: jit-if-word
+USERENV: jit-if 30
-SYMBOL: jit-if-1
+USERENV: jit-epilog 31
-SYMBOL: jit-if-2
+USERENV: jit-return 32
-SYMBOL: jit-dispatch-word
+USERENV: jit-profiling 33
-SYMBOL: jit-dispatch
+USERENV: jit-push-immediate 34
-SYMBOL: jit-dip-word
+USERENV: jit-dip-word 35
-SYMBOL: jit-dip
+USERENV: jit-dip 36
-SYMBOL: jit-2dip-word
+USERENV: jit-2dip-word 37
-SYMBOL: jit-2dip
+USERENV: jit-2dip 38
-SYMBOL: jit-3dip-word
+USERENV: jit-3dip-word 39
-SYMBOL: jit-3dip
+USERENV: jit-3dip 40
-SYMBOL: jit-epilog
+USERENV: jit-execute-word 41
-SYMBOL: jit-return
+USERENV: jit-execute-jump 42
-SYMBOL: jit-profiling
+USERENV: jit-execute-call 43
-SYMBOL: jit-declare-word
+
-SYMBOL: jit-save-stack
+! PIC stubs
+USERENV: pic-load 47
+USERENV: pic-tag 48
+USERENV: pic-hi-tag 49
+USERENV: pic-tuple 50
+USERENV: pic-hi-tag-tuple 51
+USERENV: pic-check-tag 52
+USERENV: pic-check 53
+USERENV: pic-hit 54
+USERENV: pic-miss-word 55
+USERENV: pic-miss-tail-word 56
+
+! Megamorphic dispatch
+USERENV: mega-lookup 57
+USERENV: mega-lookup-word 58
+USERENV: mega-miss-word 59
 
 ! Default definition for undefined words
-SYMBOL: undefined-quot
+USERENV: undefined-quot 60
-
-: userenvs ( -- assoc )
-    H{
-        { bootstrap-boot-quot 20 }
-        { bootstrap-global 21 }
-        { jit-code-format 22 }
-        { jit-prolog 23 }
-        { jit-primitive-word 24 }
-        { jit-primitive 25 }
-        { jit-word-jump 26 }
-        { jit-word-call 27 }
-        { jit-if-word 28 }
-        { jit-if-1 29 }
-        { jit-if-2 30 }
-        { jit-dispatch-word 31 }
-        { jit-dispatch 32 }
-        { jit-epilog 33 }
-        { jit-return 34 }
-        { jit-profiling 35 }
-        { jit-push-immediate 36 }
-        { jit-declare-word 42 }
-        { jit-save-stack 43 }
-        { jit-dip-word 44 }
-        { jit-dip 45 }
-        { jit-2dip-word 46 }
-        { jit-2dip 47 }
-        { jit-3dip-word 48 }
-        { jit-3dip 49 }
-        { undefined-quot 60 }
-    } ; inline
 
 : userenv-offset ( symbol -- n )
-    userenvs at header-size + ;
+    userenvs get at header-size + ;
 
 : emit ( cell -- ) image get push ;
 
@@ -205,8 +206,8 @@ SYMBOL: undefined-quot
 
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
-: emit-object ( header tag quot -- addr )
+: emit-object ( class quot -- addr )
-    swap here-as [ swap tag-fixnum emit call align-here ] dip ;
+    over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
     inline
 
 ! Write an object to the image.
@@ -251,7 +252,7 @@ GENERIC: ' ( obj -- ptr )
 
 M: bignum '
     [
-        bignum tag-number dup [ emit-bignum ] emit-object
+        bignum [ emit-bignum ] emit-object
     ] cache-object ;
 
 ! Fixnums
@@ -274,7 +275,7 @@ M: fake-bignum ' n>> tag-fixnum ;
 
 M: float '
     [
-        float tag-number dup [
+        float [
             align-here double>bits emit-64
         ] emit-object
     ] cache-object ;
@@ -309,7 +310,8 @@ M: f '
                     [ vocabulary>> , ]
                     [ def>> , ]
                     [ props>> , ]
-                    [ drop f , ]
+                    [ pic-def>> , ]
+                    [ pic-tail-def>> , ]
                     [ drop 0 , ] ! count
                     [ word-sub-primitive , ]
                     [ drop 0 , ] ! xt
@@ -318,8 +320,7 @@ M: f '
                 } cleave
             ] { } make [ ' ] map
         ] bi
-        \ word type-number object tag-number
+        \ word [ emit-seq ] emit-object
-        [ emit-seq ] emit-object
     ] keep put-object ;
 
 : word-error ( word msg -- * )
@@ -340,8 +341,7 @@ M: word ' ;
 ! Wrappers
 
 M: wrapper '
-    wrapped>> ' wrapper type-number object tag-number
+    wrapped>> ' wrapper [ emit ] emit-object ;
-    [ emit ] emit-object ;
 
 ! Strings
 : native> ( object -- object )
@@ -370,7 +370,7 @@ M: wrapper '
 
 : emit-string ( string -- ptr )
     [ length ] [ extended-part ' ] [ ] tri
-    string type-number object tag-number [
+    string [
         [ emit-fixnum ]
         [ emit ]
         [ f ' emit ascii-part pad-bytes emit-bytes ]
@@ -387,12 +387,11 @@ M: string '
 
 : emit-dummy-array ( obj type -- ptr )
     [ assert-empty ] [
-        type-number object tag-number
         [ 0 emit-fixnum ] emit-object
     ] bi* ;
 
 M: byte-array '
-    byte-array type-number object tag-number [
+    byte-array [
         dup length emit-fixnum
         pad-bytes emit-bytes
     ] emit-object ;
@@ -406,7 +405,7 @@ ERROR: tuple-removed class ;
 : (emit-tuple) ( tuple -- pointer )
     [ tuple-slots ]
     [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
-    tuple type-number dup [ emit-seq ] emit-object ;
+    tuple [ emit-seq ] emit-object ;
 
 : emit-tuple ( tuple -- pointer )
     dup class name>> "tombstone" =
@@ -421,8 +420,7 @@ M: tombstone '
 
 ! Arrays
 : emit-array ( array -- offset )
-    [ ' ] map array type-number object tag-number
+    [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
-    [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
 M: array ' emit-array ;
 
@@ -448,7 +446,7 @@ M: tuple-layout-array '
 M: quotation '
     [
         array>> '
-        quotation type-number object tag-number [
+        quotation [
             emit ! array
             f ' emit ! compiled
             f ' emit ! cached-effect
@@ -472,47 +470,23 @@ M: quotation '
         class<=-cache class-not-cache classes-intersect-cache
         class-and-cache class-or-cache next-method-quot-cache
     } [ H{ } clone ] H{ } map>assoc assoc-union
-    bootstrap-global set
+    bootstrap-global set ;
-    bootstrap-global emit-userenv ;
-
-: emit-boot-quot ( -- )
-    bootstrap-boot-quot emit-userenv ;
 
 : emit-jit-data ( -- )
     \ if jit-if-word set
-    \ dispatch jit-dispatch-word set
     \ do-primitive jit-primitive-word set
-    \ declare jit-declare-word set
     \ dip jit-dip-word set
     \ 2dip jit-2dip-word set
     \ 3dip jit-3dip-word set
-    [ undefined ] undefined-quot set
+    \ (execute) jit-execute-word set
-    {
+    \ inline-cache-miss \ pic-miss-word set
-        jit-code-format
+    \ inline-cache-miss-tail \ pic-miss-tail-word set
-        jit-prolog
+    \ mega-cache-lookup \ mega-lookup-word set
-        jit-primitive-word
+    \ mega-cache-miss \ mega-miss-word set
-        jit-primitive
+    [ undefined ] undefined-quot set ;
-        jit-word-jump
+
-        jit-word-call
+: emit-userenvs ( -- )
-        jit-push-immediate
+    userenvs get keys [ emit-userenv ] each ;
-        jit-if-word
-        jit-if-1
-        jit-if-2
-        jit-dispatch-word
-        jit-dispatch
-        jit-dip-word
-        jit-dip
-        jit-2dip-word
-        jit-2dip
-        jit-3dip-word
-        jit-3dip
-        jit-epilog
-        jit-return
-        jit-profiling
-        jit-declare-word
-        jit-save-stack
-        undefined-quot
-    } [ emit-userenv ] each ;
 
 : fixup-header ( -- )
     heap-size data-heap-size-offset fixup ;
@@ -529,8 +503,8 @@ M: quotation '
     emit-jit-data
     "Serializing global namespace..." print flush
     emit-global
-    "Serializing boot quotation..." print flush
+    "Serializing user environment..." print flush
-    emit-boot-quot
+    emit-userenvs
     "Performing word fixups..." print flush
     fixup-words
     "Performing header fixups..." print flush

basis/bootstrap/image/syntax/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/bootstrap/image/syntax/syntax.factor

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

basis/bootstrap/stage2.factor

@@ -35,10 +35,6 @@ SYMBOL: bootstrap-time
     "Core bootstrap completed in " write core-bootstrap-time get print-time
     "Bootstrap completed in "      write bootstrap-time      get print-time
 
-    [ optimized>> ] count-words " compiled words" print
-    [ symbol? ] count-words " symbol words" print
-    [ ] count-words " words total" print
-    
     "Bootstrapping is complete." print
     "Now, you can run Factor:" print
     vm write " -i=" write "output-image" get print flush ;
@@ -69,7 +65,6 @@ SYMBOL: bootstrap-time
         "stage2: deployment mode" print
     ] [
         "debugger" require
-        "alien.prettyprint" require
         "inspector" require
         "tools.errors" require
         "listener" require

basis/bootstrap/tools/tools.factor

@@ -14,7 +14,8 @@ IN: bootstrap.tools
     "tools.test"
     "tools.time"
     "tools.threads"
-    "tools.vocabs"
+    "vocabs.hierarchy"
-    "tools.vocabs.monitor"
+    "vocabs.refresh"
+    "vocabs.refresh.monitor"
     "editors"
 } [ require ] each

basis/calendar/windows/windows.factor

@@ -1,5 +1,5 @@
-USING: calendar namespaces alien.c-types system windows
+USING: calendar namespaces alien.c-types system
-windows.kernel32 kernel math combinators ;
+windows.kernel32 kernel math combinators windows.errors ;
 IN: calendar.windows
 
 M: windows gmt-offset ( -- hours minutes seconds )

basis/checksums/common/common.factor

@@ -9,6 +9,9 @@ SYMBOL: bytes-read
 : calculate-pad-length ( length -- length' )
     [ 56 < 55 119 ? ] keep - ;
 
+: calculate-pad-length-long ( length -- length' )
+    [ 120 < 119 247 ? ] keep - ;
+
 : pad-last-block ( str big-endian? length -- str )
     [
         [ % ] 2dip HEX: 80 ,

basis/checksums/sha2/sha2-tests.factor

@@ -1,7 +1,42 @@
-USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
+USING: arrays kernel math namespaces sequences tools.test
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
+checksums.sha2 checksums ;
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
+IN: checksums.sha2.tests
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
+
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
+: test-checksum ( text identifier -- checksum )
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
+    checksum-bytes hex-string ;
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
+
+[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
+[
+    "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
+    sha-224 test-checksum
+] unit-test
+
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
+[ "" sha-256 test-checksum ] unit-test
+
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
+[ "abc" sha-256 test-checksum ] unit-test
+
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
+[ "message digest" sha-256 test-checksum ] unit-test
+
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
+[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
+
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
+[
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+    sha-256 test-checksum
+] unit-test
+
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
+[
+    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+    sha-256 test-checksum
+] unit-test
+
+
+
+
+! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
+! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test

basis/checksums/sha2/sha2.factor

@@ -2,12 +2,27 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings ;
+sbufs strings combinators.smart math.ranges fry combinators
+accessors locals ;
 IN: checksums.sha2
 
-<PRIVATE
+SINGLETON: sha-224
+SINGLETON: sha-256
 
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
+INSTANCE: sha-224 checksum
+INSTANCE: sha-256 checksum
+
+TUPLE: sha2-state K H word-size block-size ;
+
+TUPLE: sha2-short < sha2-state ;
+
+TUPLE: sha2-long < sha2-state ;
+
+TUPLE: sha-224-state < sha2-short ;
+
+TUPLE: sha-256-state < sha2-short ;
+
+<PRIVATE
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -18,13 +33,43 @@ CONSTANT: f 5
 CONSTANT: g 6
 CONSTANT: h 7
 
-: initial-H-256 ( -- seq )
+CONSTANT: initial-H-224
+    {
+        HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
+        HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
+    }
+
+CONSTANT: initial-H-256
     {
         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
-    } ;
+    }
 
-: K-256 ( -- seq )
+CONSTANT: initial-H-384
+    {
+        HEX: cbbb9d5dc1059ed8
+        HEX: 629a292a367cd507
+        HEX: 9159015a3070dd17
+        HEX: 152fecd8f70e5939
+        HEX: 67332667ffc00b31
+        HEX: 8eb44a8768581511
+        HEX: db0c2e0d64f98fa7
+        HEX: 47b5481dbefa4fa4
+    }
+
+CONSTANT: initial-H-512
+    {
+        HEX: 6a09e667f3bcc908
+        HEX: bb67ae8584caa73b
+        HEX: 3c6ef372fe94f82b
+        HEX: a54ff53a5f1d36f1
+        HEX: 510e527fade682d1
+        HEX: 9b05688c2b3e6c1f
+        HEX: 1f83d9abfb41bd6b
+        HEX: 5be0cd19137e2179
+    }
+
+CONSTANT: K-256
     {
         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
         HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
@@ -42,62 +87,163 @@ CONSTANT: h 7
         HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
         HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
-    } ;
+    }
+
+CONSTANT: K-384
+    {
+
+        HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc 
+        HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118 
+        HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
+        HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 
+        HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 
+        HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 
+        HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 
+        HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 
+        HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df 
+        HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b 
+        HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 
+        HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 
+        HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 
+        HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 
+        HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec 
+        HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b 
+        HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 
+        HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b 
+        HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c 
+        HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
+    }
+
+ALIAS: K-512 K-384
 
 : s0-256 ( x -- x' )
-    [ -7 bitroll-32 ] keep
+    [
-    [ -18 bitroll-32 ] keep
+        [ -7 bitroll-32 ]
-    -3 shift bitxor bitxor ; inline
+        [ -18 bitroll-32 ]
+        [ -3 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : s1-256 ( x -- x' )
-    [ -17 bitroll-32 ] keep
+    [
-    [ -19 bitroll-32 ] keep
+        [ -17 bitroll-32 ]
-    -10 shift bitxor bitxor ; inline
+        [ -19 bitroll-32 ]
-
+        [ -10 shift ] tri
-: process-M-256 ( seq n -- )
+    ] [ bitxor ] reduce-outputs ; inline
-    [ 16 - swap nth ] 2keep
-    [ 15 - swap nth s0-256 ] 2keep
-    [ 7 - swap nth ] 2keep
-    [ 2 - swap nth s1-256 ] 2keep
-    [ + + w+ ] 2dip swap set-nth ; inline
-
-: prepare-message-schedule ( seq -- w-seq )
-    word-size get group [ be> ] map block-size get 0 pad-tail
-    dup 16 64 dup <slice> [
-        process-M-256
-    ] with each ;
-
-: ch ( x y z -- x' )
-    [ bitxor bitand ] keep bitxor ;
-
-: maj ( x y z -- x' )
-    [ [ bitand ] 2keep bitor ] dip bitand bitor ;
 
 : S0-256 ( x -- x' )
-    [ -2 bitroll-32 ] keep
+    [
-    [ -13 bitroll-32 ] keep
+        [ -2 bitroll-32 ]
-    -22 bitroll-32 bitxor bitxor ; inline
+        [ -13 bitroll-32 ]
+        [ -22 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : S1-256 ( x -- x' )
-    [ -6 bitroll-32 ] keep
+    [
-    [ -11 bitroll-32 ] keep
+        [ -6 bitroll-32 ]
-    -25 bitroll-32 bitxor bitxor ; inline
+        [ -11 bitroll-32 ]
+        [ -25 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
+: s0-512 ( x -- x' )
+    [
+        [ -1 bitroll-64 ]
+        [ -8 bitroll-64 ]
+        [ -7 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: T1 ( W n -- T1 )
+: s1-512 ( x -- x' )
-    [ swap nth ] keep
+    [
-    K get nth +
+        [ -19 bitroll-64 ]
-    e vars get slice3 ch +
+        [ -61 bitroll-64 ]
-    e vars get nth S1-256 +
+        [ -6 shift ] tri
-    h vars get nth w+ ;
+    ] [ bitxor ] reduce-outputs ; inline
 
-: T2 ( -- T2 )
+: S0-512 ( x -- x' )
-    a vars get nth S0-256
+    [
-    a vars get slice3 maj w+ ;
+        [ -28 bitroll-64 ]
+        [ -34 bitroll-64 ]
+        [ -39 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: update-vars ( T1 T2 -- )
+: S1-512 ( x -- x' )
-    vars get
+    [
+        [ -14 bitroll-64 ]
+        [ -18 bitroll-64 ]
+        [ -41 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: process-M-256 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
+: process-M-512 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-512 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
+: ch ( x y z -- x' )
+    [ bitxor bitand ] keep bitxor ; inline
+
+: maj ( x y z -- x' )
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
+
+: slice3 ( n seq -- a b c )
+    [ dup 3 + ] dip <slice> first3 ; inline
+
+GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
+
+M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
+    drop
+    dup [
+        HEX: 80 ,
+        length
+        [ 64 mod calculate-pad-length 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
+    drop dup [
+        HEX: 80 ,
+        length
+        [ 128 mod calculate-pad-length-long 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+: seq>byte-array ( seq n -- string )
+    '[ _ >be ] map B{ } join ;
+
+:: T1-256 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-256 w+
+    h H nth w+ ; inline
+
+: T2-256 ( H -- T2 )
+    [ a swap nth S0-256 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
+:: T1-512 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-512 w+
+    h H nth w+ ; inline
+
+: T2-512 ( H -- T2 )
+    [ a swap nth S0-512 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
+: update-H ( T1 T2 H -- )
     h g pick exchange
     g f pick exchange
     f e pick exchange
@@ -105,42 +251,56 @@ CONSTANT: h 7
     d c pick exchange
     c b pick exchange
     b a pick exchange
-    [ w+ a ] dip set-nth ;
+    [ w+ a ] dip set-nth ; inline
 
-: process-chunk ( M -- )
+: prepare-message-schedule ( seq sha2 -- w-seq )
-    H get clone vars set
+    [ word-size>> <sliced-groups> [ be> ] map ]
-    prepare-message-schedule block-size get [
+    [
-        T1 T2 update-vars
+        block-size>> [ 0 pad-tail 16 ] keep [a,b) over
-    ] with each vars get H get [ w+ ] 2map H set ;
+        '[ _ process-M-256 ] each
+    ] bi ; inline
 
-: seq>byte-array ( n seq -- string )
+:: process-chunk ( M block-size cloned-H sha2 -- )
-    [ swap [ >be % ] curry each ] B{ } make ;
+    block-size [
+        M cloned-H sha2 T1-256
+        cloned-H T2-256
+        cloned-H update-H
+    ] each
+    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
 
-: preprocess-plaintext ( string big-endian? -- padded-string )
+: sha2-steps ( sliced-groups state -- )
-    #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
+    '[
-    [ >sbuf ] dip over [
+        _
-        HEX: 80 ,
+        [ prepare-message-schedule ]
-        dup length HEX: 3f bitand
+        [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
-        calculate-pad-length 0 <string> %
+    ] each ;
-        length 3 shift 8 rot [ >be ] [ >le ] if %
-    ] "" make over push-all ;
 
-: byte-array>sha2 ( byte-array -- string )
+: byte-array>sha2 ( bytes state -- )
-    t preprocess-plaintext
+    [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
-    block-size get group [ process-chunk ] each
+    [ sha2-steps ] bi ;
-    4 H get seq>byte-array ;
+
+: <sha-224-state> ( -- sha2-state )
+    sha-224-state new
+        K-256 >>K
+        initial-H-224 >>H
+        4 >>word-size
+        64 >>block-size ;
+
+: <sha-256-state> ( -- sha2-state )
+    sha-256-state new
+        K-256 >>K
+        initial-H-256 >>H
+        4 >>word-size
+        64 >>block-size ;
 
 PRIVATE>
 
-SINGLETON: sha-256
+M: sha-224 checksum-bytes
-
+    drop <sha-224-state>
-INSTANCE: sha-256 checksum
+    [ byte-array>sha2 ]
+    [ H>> 7 head 4 seq>byte-array ] bi ;
 
 M: sha-256 checksum-bytes
-    drop [
+    drop <sha-256-state>
-        K-256 K set
+    [ byte-array>sha2 ]
-        initial-H-256 H set
+    [ H>> 4 seq>byte-array ] bi ;
-        4 word-size set
-        64 block-size set
-        byte-array>sha2
-    ] with-scope ;

basis/cocoa/application/application.factor

@@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel
 NSApplicationDelegateReplyFailure ;
 
 : with-autorelease-pool ( quot -- )
-    NSAutoreleasePool -> new slip -> release ; inline
+    NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
 
 : NSApp ( -- app ) NSApplication -> sharedApplication ;
 

basis/cocoa/cocoa.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler io kernel cocoa.runtime cocoa.subclassing
 cocoa.messages cocoa.types sequences words vocabs parser
@@ -7,7 +7,7 @@ compiler.units lexer init ;
 IN: cocoa
 
 : (remember-send) ( selector variable -- )
-    global [ dupd ?set-at ] change-at ;
+    [ dupd ?set-at ] change-global ;
 
 SYMBOL: sent-messages
 
@@ -27,22 +27,16 @@ SYMBOL: frameworks
 
 frameworks [ V{ } clone ] initialize
 
-[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
+[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
 
 SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
 
 SYNTAX: IMPORT: scan [ ] import-objc-class ;
 
-"Compiling Objective C bridge..." print
+"Importing Cocoa classes..." print
 
 "cocoa.classes" create-vocab drop
 
-{
-    "cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
-} [ words ] map concat compile
-
-"Importing Cocoa classes..." print
-
 [
     {
         "NSApplication"

basis/cocoa/dialogs/dialogs.factor

@@ -12,6 +12,9 @@ IN: cocoa.dialogs
     dup 1 -> setResolvesAliases:
     dup 1 -> setAllowsMultipleSelection: ;
 
+: <NSDirPanel> ( -- panel ) <NSOpenPanel>
+   dup 1 -> setCanChooseDirectories: ;
+
 : <NSSavePanel> ( -- panel )
     NSSavePanel -> savePanel
     dup 1 -> setCanChooseFiles:
@@ -21,11 +24,13 @@ IN: cocoa.dialogs
 CONSTANT: NSOKButton 1
 CONSTANT: NSCancelButton 0
 
-: open-panel ( -- paths )
+: (open-panel) ( panel -- paths )
-    <NSOpenPanel>
     dup -> runModal NSOKButton =
     [ -> filenames CF>string-array ] [ drop f ] if ;
     
+: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
+: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
+
 : split-path ( path -- dir file )
     "/" split1-last [ <NSString> ] bi@ ;
 

basis/cocoa/plists/plists.factor

@@ -4,7 +4,7 @@
 USING: strings arrays hashtables assocs sequences fry macros
 cocoa.messages cocoa.classes cocoa.application cocoa kernel
 namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types words core-foundation
+combinators alien.c-types words core-foundation quotations
 core-foundation.data core-foundation.utilities ;
 IN: cocoa.plists
 
@@ -41,10 +41,16 @@ DEFER: plist>
     *void* [ -> release "read-plist failed" throw ] when* ;
 
 MACRO: objc-class-case ( alist -- quot )
-    [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
+    [
+        dup callable?
+        [ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
+        unless
+    ] map '[ _ cond ] ;
 
 PRIVATE>
 
+ERROR: invalid-plist-object object ;
+
 : plist> ( plist -- value )
     {
         { NSString [ (plist-NSString>) ] }
@@ -53,6 +59,7 @@ PRIVATE>
         { NSArray [ (plist-NSArray>) ] }
         { NSDictionary [ (plist-NSDictionary>) ] }
         { NSObject [ ] }
+        [ invalid-plist-object ]
     } objc-class-case ;
 
 : read-plist ( path -- assoc )

basis/cocoa/views/views-docs.factor

@@ -1,13 +1,9 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup ui.pixel-formats ;
 IN: cocoa.views
 
-HELP: <PixelFormat>
-{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
-{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ;
-
 HELP: <GLView>
-{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "view" "a new " { $snippet "NSOpenGLView" } } }
+{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "pixel-format" pixel-format } { "view" "a new " { $snippet "NSOpenGLView" } } }
-{ $description "Creates a new instance of the specified class, giving it a default pixel format and the given size." } ;
+{ $description "Creates a new instance of the specified class, giving it the specified pixel format and size." } ;
 
 HELP: view-dim
 { $values { "view" "an " { $snippet "NSView" } } { "dim" "a pair of real numbers" } }
@@ -18,7 +14,6 @@ HELP: mouse-location
 { $description "Outputs the current mouse location." } ;
 
 ARTICLE: "cocoa-view-utils" "Cocoa view utilities"
-{ $subsection <PixelFormat> }
 { $subsection <GLView> }
 { $subsection view-dim }
 { $subsection mouse-location } ;

basis/cocoa/views/views.factor

@@ -42,39 +42,10 @@ CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
 CONSTANT: NSOpenGLPFAVirtualScreenCount 128
 CONSTANT: NSOpenGLCPSwapInterval 222
 
-<PRIVATE
+: <GLView> ( class dim pixel-format -- view )
-
+    [ -> alloc ]
-SYMBOL: software-renderer?
+    [ [ 0 0 ] dip first2 <CGRect> ]
-SYMBOL: multisample?
+    [ handle>> ] tri*
-
-PRIVATE>
-
-: with-software-renderer ( quot -- )
-    [ t software-renderer? ] dip with-variable ; inline
-
-: with-multisample ( quot -- )
-    [ t multisample? ] dip with-variable ; inline
-
-: <PixelFormat> ( attributes -- pixelfmt )
-    NSOpenGLPixelFormat -> alloc swap [
-        %
-        NSOpenGLPFADepthSize , 16 ,
-        software-renderer? get [
-            NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
-        ] when
-        multisample? get [
-            NSOpenGLPFASupersample ,
-            NSOpenGLPFASampleBuffers , 1 ,
-            NSOpenGLPFASamples , 8 ,
-        ] when
-        0 ,
-    ] int-array{ } make
-    -> initWithAttributes:
-    -> autorelease ;
-
-: <GLView> ( class dim -- view )
-    [ -> alloc 0 0 ] dip first2 <CGRect>
-    NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
     -> initWithFrame:pixelFormat:
     dup 1 -> setPostsBoundsChangedNotifications:
     dup 1 -> setPostsFrameChangedNotifications: ;

basis/combinators/smart/smart.factor

@@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
     [ infer in>> ] keep
     '[ _ firstn @ ] ;
 
+MACRO: input<sequence-unsafe ( quot -- newquot )
+    [ infer in>> ] keep
+    '[ _ firstn-unsafe @ ] ;
+
 MACRO: reduce-outputs ( quot operation -- newquot )
     [ dup infer out>> 1 [-] ] dip n*quot compose ;
 

basis/command-line/command-line-docs.factor

@@ -1,5 +1,4 @@
-USING: help.markup help.syntax parser vocabs.loader strings
+USING: help.markup help.syntax parser vocabs.loader strings ;
-command-line.private ;
 IN: command-line
 
 HELP: run-bootstrap-init
@@ -53,6 +52,7 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
     { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
     { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
     { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
+    { { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
     { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
 }
 "If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;

basis/command-line/command-line.factor

@@ -1,14 +1,14 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: init continuations hashtables io io.encodings.utf8
 io.files io.pathnames kernel kernel.private namespaces parser
-sequences strings system splitting vocabs.loader ;
+sequences strings system splitting vocabs.loader alien.strings ;
 IN: command-line
 
 SYMBOL: script
 SYMBOL: command-line
 
-: (command-line) ( -- args ) 10 getenv sift ;
+: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
 
 : rc-path ( name -- path )
     os windows? [ "." prepend ] unless

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

@@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot
         [ tuple ##set-slots ] [ ds-push drop ] 2bi
     ] [ drop emit-primitive ] if ;
 
-: store-length ( len reg -- )
+: store-length ( len reg class -- )
-    [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
+    [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
 
-: store-initial-element ( elt reg len -- )
+:: store-initial-element ( len reg elt class -- )
-    [ 2 + object tag-number ##set-slot-imm ] with with each ;
+    len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
 
 : expand-<array>? ( obj -- ? )
     dup integer? [ 0 8 between? ] [ drop f ] if ;
@@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot
             [let | elt [ ds-pop ]
                    reg [ len ^^allot-array ] |
                 ds-drop
-                len reg store-length
+                len reg array store-length
-                elt reg len store-initial-element
+                len reg elt array store-initial-element
                 reg ds-push
             ]
         ] [ node emit-primitive ] if
@@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot
 : emit-allot-byte-array ( len -- dst )
     ds-drop
     dup ^^allot-byte-array
-    [ store-length ] [ ds-push ] [ ] tri ;
+    [ byte-array store-length ] [ ds-push ] [ ] tri ;
 
 : emit-(byte-array) ( node -- )
     dup node-input-infos first literal>> dup expand-<byte-array>?
     [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
 
-: emit-<byte-array> ( node -- )
+:: emit-<byte-array> ( node -- )
-    dup node-input-infos first literal>> dup expand-<byte-array>? [
+    node node-input-infos first literal>> dup expand-<byte-array>? [
-        nip
+        :> len
-        [ 0 ^^load-literal ] dip
+        0 ^^load-literal :> elt
-        [ emit-allot-byte-array ] keep
+        len emit-allot-byte-array :> reg
-        bytes>cells store-initial-element
+        len reg elt byte-array store-initial-element
-    ] [ drop emit-primitive ] if ;
+    ] [ drop node emit-primitive ] if ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics
     arrays:<array>
     byte-arrays:<byte-array>
     byte-arrays:(byte-array)
-    math.private:<complex>
-    math.private:<ratio>
     kernel:<wrapper>
     alien.accessors:alien-unsigned-1
     alien.accessors:set-alien-unsigned-1
@@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics
         { \ arrays:<array> [ emit-<array> iterate-next ] }
         { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
         { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
-        { \ math.private:<complex> [ emit-simple-allot iterate-next ] }
-        { \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
         { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
         { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
         { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }

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

@@ -92,7 +92,7 @@ sequences ;
         T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
-        T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
+        T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
         T{ ##replace f V int-regs 6 D 0 }
     } value-numbering trim-temps
 ] unit-test
@@ -110,7 +110,7 @@ sequences ;
         T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
-        T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
+        T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
         T{ ##replace f V int-regs 6 D 0 }
     } value-numbering trim-temps
 ] unit-test
@@ -132,7 +132,7 @@ sequences ;
         T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
         T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
         T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
-        T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
+        T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
         T{ ##replace f V int-regs 14 D 0 }
     } value-numbering trim-temps
 ] unit-test
@@ -149,6 +149,6 @@ sequences ;
         T{ ##peek f V int-regs 29 D -1 }
         T{ ##peek f V int-regs 30 D -2 }
         T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
-        T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
+        T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
     } value-numbering trim-temps
 ] unit-test

basis/compiler/codegen/codegen.factor

@@ -3,7 +3,7 @@
 USING: namespaces make math math.order math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
-alien.strings alien.arrays alien.complex sets libc alien.libraries
+alien.strings alien.arrays alien.complex alien.libraries sets libc
 continuations.private fry cpu.architecture
 source-files.errors
 compiler.errors
@@ -44,7 +44,7 @@ SYMBOL: calls
 
 SYMBOL: compiling-word
 
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
+: compiled-stack-traces? ( -- ? ) 67 getenv ;
 
 ! Mapping _label IDs to label instances
 SYMBOL: labels
@@ -88,7 +88,7 @@ M: ##call generate-insn
     word>> dup sub-primitive>>
     [ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
 
-M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
+M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 
 M: ##return generate-insn drop %return ;
 
@@ -444,8 +444,7 @@ TUPLE: callback-context ;
 
 : do-callback ( quot token -- )
     init-catchstack
-    dup 2 setenv
+    [ 2 setenv call ] keep
-    slip
     wait-to-return ; inline
 
 : callback-return-quot ( ctype -- quot )

basis/compiler/codegen/fixup/fixup.factor

@@ -3,15 +3,13 @@
 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 words.private math.order
+system combinators math.bitwise math.order
 accessors growable cpu.architecture compiler.constants ;
 IN: compiler.codegen.fixup
 
 GENERIC: fixup* ( obj -- )
 
-: code-format ( -- n ) 22 getenv ;
+: compiled-offset ( -- n ) building get length ;
-
-: compiled-offset ( -- n ) building get length code-format * ;
 
 SYMBOL: relocation-table
 SYMBOL: label-table
@@ -25,7 +23,7 @@ TUPLE: label-fixup label class ;
 M: label-fixup fixup*
     dup class>> rc-absolute?
     [ "Absolute labels not supported" throw ] when
-    [ label>> ] [ class>> ] bi compiled-offset 4 - rot
+    [ class>> ] [ label>> ] bi compiled-offset 4 - swap
     3array label-table get push ;
 
 TUPLE: rel-fixup class type ;
@@ -58,6 +56,12 @@ SYMBOL: literal-table
 : rel-word ( word class -- )
     [ add-literal ] dip rt-xt rel-fixup ;
 
+: rel-word-pic ( word class -- )
+    [ add-literal ] dip rt-xt-pic rel-fixup ;
+
+: rel-word-pic-tail ( word class -- )
+    [ add-literal ] dip rt-xt-pic-tail rel-fixup ;
+
 : rel-primitive ( word class -- )
     [ def>> first add-literal ] dip rt-primitive rel-fixup ;
 
@@ -88,4 +92,4 @@ SYMBOL: literal-table
         literal-table get >array
         relocation-table get >byte-array
         label-table get resolve-labels
-    ] { } make 4array ;
+    ] B{ } make 4array ;

basis/compiler/compiler-docs.factor

@@ -1,19 +1,19 @@
 USING: assocs compiler.cfg.builder compiler.cfg.optimizer
 compiler.errors compiler.tree.builder compiler.tree.optimizer
 compiler.units help.markup help.syntax io parser quotations
-sequences words words.private ;
+sequences words ;
 IN: compiler
 
-HELP: enable-compiler
+HELP: enable-optimizer
 { $description "Enables the optimizing compiler." } ;
 
-HELP: disable-compiler
+HELP: disable-optimizer
 { $description "Disable the optimizing compiler." } ;
 
 ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 "Normally, new word definitions are recompiled automatically. This can be changed:"
-{ $subsection disable-compiler }
+{ $subsection disable-optimizer }
-{ $subsection enable-compiler }
+{ $subsection enable-optimizer }
 "Removing a word's optimized definition:"
 { $subsection decompile }
 "Compiling a single quotation:"

basis/compiler/compiler.factor

@@ -2,19 +2,20 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces arrays sequences io words fry
 continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io source-files.errors
+generic.single combinators deques search-deques macros io
-stack-checker stack-checker.state stack-checker.inlining
+source-files.errors stack-checker stack-checker.state
-stack-checker.errors combinators.short-circuit compiler.errors
+stack-checker.inlining stack-checker.errors combinators.short-circuit
-compiler.units compiler.tree.builder compiler.tree.optimizer
+compiler.errors compiler.units compiler.tree.builder
-compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.two-operand compiler.cfg.linear-scan
+compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
+compiler.utilities ;
 IN: compiler
 
 SYMBOL: compile-queue
 SYMBOL: compiled
 
-: queue-compile? ( word -- ? )
+: compile? ( word -- ? )
     #! Don't attempt to compile certain words.
     {
         [ "forgotten" word-prop ]
@@ -24,7 +25,7 @@ SYMBOL: compiled
     } 1|| not ;
 
 : queue-compile ( word -- )
-    dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
+    dup compile? [ compile-queue get push-front ] [ drop ] if ;
 
 : recompile-callers? ( word -- ? )
     changed-effects get key? ;
@@ -41,6 +42,14 @@ SYMBOL: compiled
     H{ } clone generic-dependencies set
     clear-compiler-error ;
 
+GENERIC: no-compile? ( word -- ? )
+
+M: word no-compile? "no-compile" word-prop ;
+
+M: method-body no-compile? "method-generic" word-prop no-compile? ;
+
+M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
+
 : ignore-error? ( word error -- ? )
     #! Ignore some errors on inline combinators, macros, and special
     #! words such as 'call'.
@@ -48,8 +57,8 @@ SYMBOL: compiled
         {
             [ macro? ]
             [ inline? ]
+            [ no-compile? ]
             [ "special" word-prop ]
-            [ "no-compile" word-prop ]
         } 1||
     ] [
         {
@@ -80,32 +89,45 @@ SYMBOL: compiled
 : not-compiled-def ( word error -- def )
     '[ _ _ not-compiled ] [ ] like ;
 
+: ignore-error ( word error -- * )
+    drop
+    [ clear-compiler-error ]
+    [ dup def>> deoptimize-with ]
+    bi ;
+
+: remember-error ( word error -- * )
+    [ swap <compiler-error> compiler-error ]
+    [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
+    2bi ;
+
 : deoptimize ( word error -- * )
     #! If the error is ignorable, compile the word with the
     #! non-optimizing compiler, using its definition. Otherwise,
     #! if the compiler error is not ignorable, use a dummy
     #! definition from 'not-compiled-def' which throws an error.
-    2dup ignore-error? [
+    {
-        drop
+        { [ dup inference-error? not ] [ rethrow ] }
-        [ dup def>> deoptimize-with ]
+        { [ 2dup ignore-error? ] [ ignore-error ] }
-        [ clear-compiler-error ]
+        [ remember-error ]
-        bi
+    } cond ;
-    ] [
+
-        [ swap <compiler-error> compiler-error ]
+: optimize? ( word -- ? )
-        [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
+    { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
-        2bi
+
-    ] if ;
+: contains-breakpoints? ( -- ? )
+    dependencies get keys [ "break?" word-prop ] any? ;
 
 : frontend ( word -- nodes )
     #! If the word contains breakpoints, don't optimize it, since
     #! the walker does not support this.
-    dup contains-breakpoints? [ dup def>> deoptimize-with ] [
+    dup optimize? [
-        [ build-tree ] [ deoptimize ] recover optimize-tree
+        [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
-    ] if ;
+        contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
+    ] [ dup def>> deoptimize-with ] if ;
 
 : compile-dependency ( word -- )
     #! If a word calls an unoptimized word, try to compile the callee.
-    dup optimized>> [ drop ] [ queue-compile ] if ;
+    dup optimized? [ drop ] [ queue-compile ] if ;
 
 ! Only switch this off for debugging.
 SYMBOL: compile-dependencies?
@@ -161,15 +183,21 @@ M: optimizing-compiler recompile ( words -- alist )
     [
         <hashed-dlist> compile-queue set
         H{ } clone compiled set
-        [ queue-compile ] each
+        [
+            [ queue-compile ]
+            [ subwords [ compile-dependency ] each ] bi
+        ] each
         compile-queue get compile-loop
         compiled get >alist
     ] with-scope ;
 
-: enable-compiler ( -- )
+: with-optimizer ( quot -- )
+    [ optimizing-compiler compiler-impl ] dip with-variable ; inline
+
+: enable-optimizer ( -- )
     optimizing-compiler compiler-impl set-global ;
 
-: disable-compiler ( -- )
+: disable-optimizer ( -- )
     f compiler-impl set-global ;
 
 : recompile-all ( -- )

basis/compiler/constants/constants.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system strings ;
+USING: math kernel layouts system strings words quotations byte-arrays
+alien arrays literals sequences ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
@@ -11,43 +12,44 @@ CONSTANT: deck-bits 18
 ! These constants must match vm/layouts.h
 : header-offset ( -- n ) object tag-number neg ; inline
 : float-offset ( -- n ) 8 float tag-number - ; inline
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
+: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
 : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
+: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
+: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
 : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
+: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
-: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
+: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
+: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
-: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
 
 ! Relocation classes
 CONSTANT: rc-absolute-cell 0
 CONSTANT: rc-absolute 1
 CONSTANT: rc-relative 2
 CONSTANT: rc-absolute-ppc-2/2 3
-CONSTANT: rc-relative-ppc-2   4
+CONSTANT: rc-absolute-ppc-2 4
-CONSTANT: rc-relative-ppc-3   5
+CONSTANT: rc-relative-ppc-2 5
-CONSTANT: rc-relative-arm-3   6
+CONSTANT: rc-relative-ppc-3 6
-CONSTANT: rc-indirect-arm     7
+CONSTANT: rc-relative-arm-3 7
-CONSTANT: rc-indirect-arm-pc  8
+CONSTANT: rc-indirect-arm 8
+CONSTANT: rc-indirect-arm-pc 9
 
 ! Relocation types
 CONSTANT: rt-primitive 0
 CONSTANT: rt-dlsym 1
 CONSTANT: rt-dispatch 2
 CONSTANT: rt-xt 3
-CONSTANT: rt-here        4
+CONSTANT: rt-xt-pic 4
-CONSTANT: rt-this        5
+CONSTANT: rt-xt-pic-tail 5
-CONSTANT: rt-immediate   6
+CONSTANT: rt-here 6
-CONSTANT: rt-stack-chain 7
+CONSTANT: rt-this 7
+CONSTANT: rt-immediate 8
+CONSTANT: rt-stack-chain 9
+CONSTANT: rt-untagged 10
+CONSTANT: rt-megamorphic-cache-hits 11
 
 : rc-absolute? ( n -- ? )
-    [ rc-absolute-ppc-2/2 = ]
+    ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
-    [ rc-absolute-cell = ]
-    [ rc-absolute = ]
-    tri or or ;

basis/compiler/tests/alien.factor

@@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
     C{ 1.0 2.0 }
     C{ 1.5 1.0 } ffi_test_47
 ] unit-test
+
+! Reported by jedahu
+C-STRUCT: bool-field-test
+   { "char*" "name" }
+   { "bool"  "on" }
+   { "short" "parents" } ;
+
+FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
+
+[ 123 ] [
+    "bool-field-test" <c-object> 123 over set-bool-field-test-parents
+    ffi_test_48
+] unit-test

basis/compiler/tests/call-effect.factor

@@ -0,0 +1,14 @@
+IN: compiler.tests.call-effect
+USING: tools.test combinators generic.single sequences kernel ;
+
+: execute-ic-test ( a b -- c ) execute( a -- c ) ;
+
+! VM type check error
+[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
+
+: call-test ( q -- ) call( -- ) ;
+
+[ ] [ [ ] call-test ] unit-test
+[ ] [ f [ drop ] curry call-test ] unit-test
+[ ] [ [ ] [ ] compose call-test ] unit-test
+[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with

basis/compiler/tests/codegen.factor

@@ -26,7 +26,7 @@ IN: compiler.tests.codegen
 
 [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
 
-[ { 1 2 3 } { 1 4 3 } 3 3 ]
+[ { 1 2 3 } { 1 4 3 } 2 2 ]
 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
 unit-test
 
@@ -37,7 +37,7 @@ unit-test
 
 : foo ( -- ) ;
 
-[ 5 5 ]
+[ 3 3 ]
 [ 1.2 [ tag [ foo ] keep ] compile-call ]
 unit-test
 
@@ -211,7 +211,7 @@ TUPLE: my-tuple ;
     { tuple vector } 3 slot { word } declare
     dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
 
-[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
+[ t ] [ \ dispatch-alignment-regression optimized? ] unit-test
 
 [ vector ] [ dispatch-alignment-regression ] unit-test
 

basis/compiler/tests/curry.factor

@@ -33,7 +33,7 @@ IN: compiler.tests.curry
 ] unit-test
 
 : foobar ( quot: ( -- ) -- )
-    dup slip swap [ foobar ] [ drop ] if ; inline recursive
+    [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
 
 [ ] [ [ [ f ] foobar ] compile-call ] unit-test
 

basis/compiler/tests/float.factor

@@ -9,7 +9,7 @@ math.private tools.test math.floats.private ;
 
 [ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
 
-[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
+[ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
 
 [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
 [ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test

basis/compiler/tests/generic.factor

@@ -0,0 +1,11 @@
+IN: compiler.tests.generic
+USING: tools.test math kernel compiler.units definitions ;
+
+GENERIC: bad ( -- )
+M: integer bad ;
+M: object bad ;
+
+[ 0 bad ] must-fail
+[ "" bad ] must-fail
+
+[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test

basis/compiler/tests/intrinsics.factor

@@ -342,12 +342,12 @@ cell 8 = [
 ] unit-test
 
 [ 1 2 ] [
-    1 2 [ <complex> ] compile-call
+    1 2 [ complex boa ] compile-call
     dup real-part swap imaginary-part
 ] unit-test
 
 [ 1 2 ] [
-    1 2 [ <ratio> ] compile-call dup numerator swap denominator
+    1 2 [ ratio boa ] compile-call dup numerator swap denominator
 ] unit-test
 
 [ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test

basis/compiler/tests/optimizer.factor

@@ -4,13 +4,13 @@ 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 ;
+compiler definitions ;
 IN: compiler.tests.optimizer
 
 GENERIC: xyz ( obj -- obj )
 M: array xyz xyz ;
 
-[ t ] [ \ xyz optimized>> ] unit-test
+[ t ] [ M\ array xyz optimized? ] unit-test
 
 ! Test predicate inlining
 : pred-test-1 ( a -- b c )
@@ -95,7 +95,7 @@ TUPLE: pred-test ;
 ! regression
 GENERIC: void-generic ( obj -- * )
 : breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage optimized>> ] unit-test
+[ t ] [ \ breakage optimized? ] unit-test
 [ breakage ] must-fail
 
 ! regression
@@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * )
 ! compiling <tuple> with a non-literal class failed
 : <tuple>-regression ( class -- tuple ) <tuple> ;
 
-[ t ] [ \ <tuple>-regression optimized>> ] unit-test
+[ t ] [ \ <tuple>-regression optimized? ] unit-test
 
 GENERIC: foozul ( a -- b )
 M: reversed foozul ;
@@ -229,7 +229,7 @@ USE: binary-search.private
 : node-successor-f-bug ( x -- * )
     [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
 
-[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
+[ t ] [ \ node-successor-f-bug optimized? ] unit-test
 
 [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
 
@@ -243,7 +243,7 @@ USE: binary-search.private
         ] if
     ] if ;
 
-[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
+[ t ] [ \ lift-throw-tail-regression optimized? ] unit-test
 [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
 [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
 
@@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ;
 : recursive-inline-hang-1 ( -- a )
     { } recursive-inline-hang ;
 
-[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
+[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
 
 DEFER: recursive-inline-hang-3
 
@@ -325,7 +325,7 @@ PREDICATE: list < improper-list
     dup "a" get { array-capacity } declare >=
     [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
 
-[ t ] [ \ interval-inference-bug optimized>> ] unit-test
+[ t ] [ \ interval-inference-bug optimized? ] unit-test
 
 [ ] [ 1 "a" set 2 "b" set ] unit-test
 [ 2 3 ] [ 2 interval-inference-bug ] unit-test
@@ -384,3 +384,15 @@ DEFER: loop-bbb
     1 >bignum 2 >bignum
     [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
 ] unit-test
+
+: broken-declaration ( -- ) \ + declare ;
+
+[ f ] [ \ broken-declaration optimized? ] unit-test
+
+[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
+
+! Modular arithmetic bug
+: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
+
+[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
+[ -10 ] [ -10 modular-arithmetic-bug ] unit-test

basis/compiler/tests/peg-regression.factor

@@ -4,7 +4,7 @@
 ! optimization, which would batch generic word updates at the
 ! end of a compilation unit.
 
-USING: kernel accessors peg.ebnf ;
+USING: kernel accessors peg.ebnf words ;
 IN: compiler.tests.peg-regression
 
 TUPLE: pipeline-expr background ;
@@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
 
 USE: tools.test
 
-[ t ] [ \ expr optimized>> ] unit-test
+[ t ] [ \ expr optimized? ] unit-test
-[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized? ] unit-test

basis/compiler/tests/pic-problem-1.factor

@@ -0,0 +1,14 @@
+IN: compiler.tests.pic-problem-1
+USING: kernel sequences prettyprint memory tools.test ;
+
+TUPLE: x ;
+
+M: x length drop 0 ;
+
+INSTANCE: x sequence
+
+<< gc >>
+
+CONSTANT: blah T{ x }
+
+[ T{ x } ] [ blah ] unit-test

basis/compiler/tests/redefine14.factor

@@ -1,8 +1,8 @@
 USING: compiler.units definitions tools.test sequences ;
 IN: compiler.tests.redefine14
 
-! TUPLE: bad ;
+TUPLE: bad ;
-! 
+
-! M: bad length 1 2 3 ;
+M: bad length 1 2 3 ;
-! 
+
-! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
+[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test

basis/compiler/tests/redefine17.factor

@@ -0,0 +1,49 @@
+IN: compiler.tests.redefine17
+USING: tools.test classes.mixin compiler.units arrays kernel.private
+strings sequences vocabs definitions kernel ;
+
+<< "compiler.tests.redefine17" words forget-all >>
+
+GENERIC: bong ( a -- b )
+
+M: array bong ;
+
+M: string bong length ;
+
+MIXIN: mixin
+
+INSTANCE: array mixin
+
+: blah ( a -- b ) { mixin } declare bong ;
+
+[ { } ] [ { } blah ] unit-test
+
+[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 0 ] [ "" blah ] unit-test
+
+MIXIN: mixin1
+
+INSTANCE: string mixin1
+
+MIXIN: mixin2
+
+GENERIC: billy ( a -- b )
+
+M: mixin2 billy ;
+
+M: array billy drop "BILLY" ;
+
+INSTANCE: string mixin2
+
+: bully ( a -- b ) { mixin1 } declare billy ;
+
+[ "" ] [ "" bully ] unit-test
+
+[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ "BILLY" ] [ { } bully ] unit-test

basis/compiler/tests/redefine3.factor

@@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
 : sheeple-test ( -- string ) { } sheeple ;
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test optimized>> ] unit-test
+[ t ] [ \ sheeple-test optimized? ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 
@@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
 [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test optimized>> ] unit-test
+[ t ] [ \ sheeple-test optimized? ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

basis/compiler/tests/simple.factor

@@ -60,8 +60,8 @@ IN: compiler.tests.simple
 
 ! Make sure error reporting works
 
-[ [ dup ] compile-call ] must-fail
+! [ [ dup ] compile-call ] must-fail
-[ [ drop ] compile-call ] must-fail
+! [ [ drop ] compile-call ] must-fail
 
 ! Regression
 
@@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
 10 [
     [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
     [ t ] [
-        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
+        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
     ] unit-test
 ] times

basis/compiler/tests/spilling.factor

@@ -1,5 +1,5 @@
 USING: math.private kernel combinators accessors arrays
-generalizations tools.test ;
+generalizations tools.test words ;
 IN: compiler.tests.spilling
 
 : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
@@ -47,7 +47,7 @@ IN: compiler.tests.spilling
 [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
 [ 1.0 float-spill-bug ] unit-test
 
-[ t ] [ \ float-spill-bug optimized>> ] unit-test
+[ t ] [ \ float-spill-bug optimized? ] unit-test
 
 : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
     {
@@ -132,7 +132,7 @@ IN: compiler.tests.spilling
 [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
 [ 1.0 float-fixnum-spill-bug ] unit-test
 
-[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
+[ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test
 
 : resolve-spill-bug ( a b -- c )
     [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@@ -159,7 +159,7 @@ IN: compiler.tests.spilling
         16 narray
     ] if ;
 
-[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
+[ t ] [ \ resolve-spill-bug optimized? ] unit-test
 
 [ 4 ] [ 1 1 resolve-spill-bug ] unit-test
 

basis/compiler/tree/builder/builder.factor

@@ -54,7 +54,7 @@ PRIVATE>
     #! This slows down compiler.tree.propagation.inlining since then every
     #! inlined usage of a method has an inline-dependency on the mixin, and
     #! not the more specific type at the call site.
-    specialize-method? off
+    f specialize-method? [
         [
             #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
             {
@@ -62,7 +62,6 @@ PRIVATE>
                 { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
                 [ in-d #call out-d>> #copy suffix ]
             } cond
-    ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
+        ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
+    ] with-variable ;
 
-: contains-breakpoints? ( word -- ? )
-    def>> [ word? ] filter [ "break?" word-prop ] any? ;

basis/compiler/tree/debugger/debugger.factor

@@ -153,7 +153,7 @@ SYMBOL: node-count
             [ 1+ ] dip
             dup #call? [
                 word>> {
-                    { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
+                    { [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
                     { [ dup generic? ] [ generics-called ] }
                     { [ dup method-body? ] [ methods-called ] }
                     [ words-called ]

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

@@ -12,7 +12,6 @@ M: #push run-escape-analysis*
 
 M: #call run-escape-analysis*
     {
-        { [ dup word>> \ <complex> eq? ] [ t ] }
         { [ dup immutable-tuple-boa? ] [ t ] }
         [ f ] 
     } cond nip ;

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

@@ -17,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
     out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
+    dup immutable-tuple-boa?
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*
@@ -291,7 +291,7 @@ C: <ro-box> ro-box
 
 [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
 
-[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
+[ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test
 
 [ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
 
@@ -302,7 +302,7 @@ C: <ro-box> ro-box
 [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
 
 : impeach-node ( quot: ( node -- ) -- )
-    dup slip impeach-node ; inline recursive
+    [ call ] keep impeach-node ; inline recursive
 
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive

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

@@ -47,9 +47,6 @@ M: #push escape-analysis*
     [ record-unknown-allocation ]
     if ;
 
-: record-complex-allocation ( #call -- )
-    [ in-d>> ] [ out-d>> first ] bi record-allocation ;
-
 : slot-offset ( #call -- n/f )
     dup in-d>>
     [ first node-value-info class>> ]
@@ -71,7 +68,6 @@ M: #push escape-analysis*
 M: #call escape-analysis*
     dup word>> {
         { \ <tuple-boa> [ record-tuple-allocation ] }
-        { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
         [ drop record-unknown-allocation ]
     } case ;

basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor

@@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ;
     ] { mod fixnum-mod } inlined?
 ] unit-test
 
-
 [ f ] [
     [
         256 mod
     ] { mod fixnum-mod } inlined?
 ] unit-test
 
+[ f ] [
+    [
+        >fixnum 256 mod
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
 [ f ] [
     [
         dup 0 >= [ 256 mod ] when
@@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ;
         { integer } declare [ 256 rem ] map
     ] { mod fixnum-mod rem } inlined?
 ] unit-test
+
+[ [ >fixnum 255 fixnum-bitand ] ]
+[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test

basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math math.partial-dispatch namespaces sequences sets
 accessors assocs words kernel memoize fry combinators
+combinators.short-circuit
 compiler.tree
 compiler.tree.combinators
 compiler.tree.def-use
@@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes )
 : optimize->fixnum ( #call -- nodes )
     dup redundant->fixnum? [ drop f ] when ;
 
+: optimize->integer ( #call -- nodes )
+    dup out-d>> first actually-used-by dup length 1 = [
+        first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
+        [ drop { } ] when
+    ] [ drop ] if ;
+
 MEMO: fixnum-coercion ( flags -- nodes )
     [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
 
@@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
 M: #call optimize-modular-arithmetic*
     dup word>> {
         { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
+        { [ dup \ >integer eq? ] [ drop optimize->integer ] }
         { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
         [ drop ]
     } cond ;

basis/compiler/tree/propagation/info/info.factor

@@ -59,29 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }
 
 : <value-info> ( -- info ) \ value-info new ;
 
-: read-only-slots ( values class -- slots )
-    all-slots
-    [ read-only>> [ drop f ] unless ] 2map
-    f prefix ;
-
 DEFER: <literal-info>
 
+: tuple-slot-infos ( tuple -- slots )
+    [ tuple-slots ] [ class all-slots ] bi
+    [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
+    f prefix ;
+
 : init-literal-info ( info -- info )
     dup literal>> class >>class
     dup literal>> dup real? [ [a,a] >>interval ] [
         [ [-inf,inf] >>interval ] dip
-        {
+        dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
-            { [ dup complex? ] [
-                [ real-part <literal-info> ]
-                [ imaginary-part <literal-info> ] bi
-                2array >>slots
-            ] }
-            { [ dup tuple? ] [
-                [ tuple-slots [ <literal-info> ] map ] [ class ] bi
-                read-only-slots >>slots
-            ] }
-            [ drop ]
-        } cond
     ] if ; inline
 
 : init-value-info ( info -- info )

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel arrays sequences math math.order
-math.partial-dispatch generic generic.standard generic.math
+math.partial-dispatch generic generic.standard generic.single generic.math
 classes.algebra classes.union sets quotations assocs combinators
 words namespaces continuations classes fry combinators.smart hints
 locals
@@ -157,11 +157,7 @@ DEFER: (flat-length)
     ] sum-outputs ;
 
 : should-inline? ( #call word -- ? )
-    {
+    dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
-        { [ dup contains-breakpoints? ] [ 2drop f ] }
-        { [ dup "inline" word-prop ] [ 2drop t ] }
-        [ inlining-rank 5 >= ]
-    } cond ;
 
 SYMBOL: history
 
@@ -188,9 +184,7 @@ SYMBOL: history
     { curry compose } memq? ;
 
 : never-inline-word? ( word -- ? )
-    [ deferred? ]
+    [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
-    [ "default" word-prop ]
-    [ { call execute } memq? ] tri or or ;
 
 : custom-inlining? ( word -- ? )
     "custom-inlining" word-prop ;

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
 comparison-ops
 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
 
-! generic-comparison-ops [
-!     dup specific-comparison define-comparison-constraints
-! ] each
-
 ! Remove redundant comparisons
 : fold-comparison ( info1 info2 word -- info )
     [ [ interval>> ] bi@ ] dip interval-comparison {
@@ -217,6 +213,8 @@ generic-comparison-ops [
     { >float float }
     { fixnum>float float }
     { bignum>float float }
+
+    { >integer integer }
 } [
     '[
         _
@@ -228,19 +226,26 @@ generic-comparison-ops [
     ] "outputs" set-word-prop
 ] assoc-each
 
+: rem-custom-inlining ( #call -- quot/f )
+    second value-info literal>> dup integer?
+    [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
+
 {
     mod-integer-integer
     mod-integer-fixnum
     mod-fixnum-integer
     fixnum-mod
-    rem
 } [
     [
-        in-d>> second value-info >literal<
+        in-d>> dup first value-info interval>> [0,inf] interval-subset?
-        [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
+        [ rem-custom-inlining ] [ drop f ] if
     ] "custom-inlining" set-word-prop
 ] each
 
+\ rem [
+    in-d>> rem-custom-inlining
+] "custom-inlining" set-word-prop
+
 {
     bitand-integer-integer
     bitand-integer-fixnum

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

@@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
 specialized-arrays.double system sorting math.libm
-math.intervals ;
+math.intervals quotations ;
 IN: compiler.tree.propagation.tests
 
 [ V{ } ] [ [ ] final-classes ] unit-test
@@ -357,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
 ] unit-test
 
 [ V{ complex } ] [
-    [ <complex> ] final-classes
+    [ complex boa ] final-classes
 ] unit-test
 
 [ V{ complex } ] [
@@ -375,7 +375,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
 [ V{ complex } ] [
     [
         { float float object } declare
-        [ "Oops" throw ] [ <complex> ] if
+        [ "Oops" throw ] [ complex boa ] if
     ] final-classes
 ] unit-test
 
@@ -590,7 +590,7 @@ MIXIN: empty-mixin
 
 [ V{ float } ] [
     [
-        [ { float float } declare <complex> ]
+        [ { float float } declare complex boa ]
         [ 2drop C{ 0.0 0.0 } ]
         if real-part
     ] final-classes
@@ -686,3 +686,11 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
 
 [ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+
+! Mutable tuples with circularity should not cause problems
+TUPLE: circle me ;
+
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
+
+! Joe found an oversight
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -109,7 +109,7 @@ M: #declare propagate-before
 
 : output-value-infos ( #call word -- infos )
     {
-        { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
+        { [ dup \ <tuple-boa> eq? ] [ drop propagate-<tuple-boa> ] }
         { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
         { [ dup predicate? ] [ propagate-predicate ] }
         { [ dup "outputs" word-prop ] [ call-outputs-quot ] }

basis/compiler/tree/propagation/slots/slots.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry assocs arrays byte-arrays strings accessors sequences
 kernel slots classes.algebra classes.tuple classes.tuple.private
@@ -8,9 +8,6 @@ IN: compiler.tree.propagation.slots
 
 ! Propagation of immutable slots and array lengths
 
-! Revisit this code when delegation is removed and when complex
-! numbers become tuples.
-
 UNION: fixed-length-sequence array byte-array string ;
 
 : sequence-constructor? ( word -- ? )
@@ -29,33 +26,26 @@ UNION: fixed-length-sequence array byte-array string ;
     [ constructor-output-class <class-info> ]
     bi* value-info-intersect 1array ;
 
-: tuple-constructor? ( word -- ? )
-    { <tuple-boa> <complex> } memq? ;
-
 : fold-<tuple-boa> ( values class -- info )
     [ [ literal>> ] map ] dip prefix >tuple
     <literal-info> ;
 
+: read-only-slots ( values class -- slots )
+    all-slots
+    [ read-only>> [ value-info ] [ drop f ] if ] 2map
+    f prefix ;
+
 : (propagate-tuple-constructor) ( values class -- info )
-    [ [ value-info ] map ] dip [ read-only-slots ] keep
+    [ read-only-slots ] keep
     over rest-slice [ dup [ literal?>> ] when ] all? [
         [ rest-slice ] dip fold-<tuple-boa>
     ] [
         <tuple-info>
     ] if ;
 
-: propagate-<tuple-boa> ( #call -- info )
+: propagate-<tuple-boa> ( #call -- infos )
     in-d>> unclip-last
-    value-info literal>> first (propagate-tuple-constructor) ;
+    value-info literal>> first (propagate-tuple-constructor) 1array ;
-
-: propagate-<complex> ( #call -- info )
-    in-d>> [ value-info ] map complex <tuple-info> ;
-
-: propagate-tuple-constructor ( #call word -- infos )
-    {
-        { \ <tuple-boa> [ propagate-<tuple-boa> ] }
-        { \ <complex> [ propagate-<complex> ] }
-    } case 1array ;
 
 : read-only-slot? ( n class -- ? )
     all-slots [ offset>> = ] with find nip

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -32,7 +32,6 @@ TUPLE: empty-tuple ;
     [ dup [ drop f ] [ "A" throw ] if ]
     [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
     [ [ ] [ ] curry curry call ]
-    [ <complex> <complex> dup 1 slot drop 2 slot drop ]
     [ 1 cons boa over [ "A" throw ] when car>> ]
     [ [ <=> ] sort ]
     [ [ <=> ] with search ]
@@ -40,7 +39,7 @@ TUPLE: empty-tuple ;
 
 ! A more complicated example
 : impeach-node ( quot: ( node -- ) -- )
-    dup slip impeach-node ; inline recursive
+    [ call ] keep impeach-node ; inline recursive
 
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes )
 : unbox-<tuple-boa> ( #call -- nodes )
     dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
 
-: unbox-<complex> ( #call -- nodes )
-    dup unbox-output? [ drop { } ] when ;
-
 : (flatten-values) ( values accum -- )
     dup '[
         dup unboxed-allocation
@@ -70,7 +67,6 @@ M: #push unbox-tuples* ( #push -- nodes )
 M: #call unbox-tuples*
     dup word>> {
         { \ <tuple-boa> [ unbox-<tuple-boa> ] }
-        { \ <complex> [ unbox-<complex> ] }
         { \ slot [ unbox-slot-access ] }
         [ drop ]
     } case ;

basis/core-foundation/fsevents/fsevents.factor

@@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks
     \ event-stream-counter counter ;
 
 [
-    event-stream-callbacks global
+    event-stream-callbacks
-    [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
+    [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
 ] "core-foundation" add-init-hook
 
 : add-event-source-callback ( quot -- id )

basis/core-graphics/core-graphics.factor

@@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
 
 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
 
+FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
+
+FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
+FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
+
+FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
+
+FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
+
 <PRIVATE
 
 : bitmap-flags ( -- flags )

basis/core-graphics/types/types.factor

@@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
 TYPEDEF: uint CGBitmapInfo
 
 TYPEDEF: int CGLError
+TYPEDEF: int CGError
+TYPEDEF: uint CGDirectDisplayID
+TYPEDEF: int boolean_t
 TYPEDEF: void* CGLContextObj
 TYPEDEF: int CGLContextParameter

basis/cpu/architecture/architecture.factor

@@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- )
 
 HOOK: stack-frame-size cpu ( stack-frame -- n )
 HOOK: %call cpu ( word -- )
+HOOK: %jump cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 

basis/cpu/ppc/assembler/assembler-tests.factor

@@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces
 make vocabs sequences ;
 
 : test-assembler ( expected quot -- )
-    [ 1array ] [ [ { } make ] curry ] bi* unit-test ;
+    [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
 
-{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
+B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
-{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
+B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
-{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
+B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
-{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
+B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
-{ HEX: 38400001 } [ 1 2 LI ] test-assembler
+B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
-{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
+B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
-{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
+B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
-{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
+B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
-{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
-{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
-{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
-{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
-{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
-{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
-{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
-{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
-{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
-{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
-{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
-{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
-{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
-{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
-{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
-{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
+B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
-{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
+B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
-{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
-{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
-{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
-{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
+B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
-{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
-{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
-{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
-{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
-{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
-{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
-{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
-{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
-{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
-{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
-{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
+B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
-{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
-{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
-{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
+B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
-{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
+B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
-{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
-{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
+B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
-{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
+B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
-{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
+B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
-{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
+B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
-{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
+B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
-{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
+B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
-{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
+B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
-{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
+B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
-{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
+B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
-{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
+B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
-{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
+B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
-{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
-{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
-{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
-{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
-{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
-{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
-{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
-{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
-{ HEX: 48000001 } [ 1 B ] test-assembler
+B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
-{ HEX: 48000001 } [ 1 BL ] test-assembler
+B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
-{ HEX: 41800004 } [ 1 BLT ] test-assembler
+B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-{ HEX: 41810004 } [ 1 BGT ] test-assembler
+B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
-{ HEX: 40810004 } [ 1 BLE ] test-assembler
+B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
-{ HEX: 40800004 } [ 1 BGE ] test-assembler
+B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
-{ HEX: 41800004 } [ 1 BLT ] test-assembler
+B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-{ HEX: 40820004 } [ 1 BNE ] test-assembler
+B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
-{ HEX: 41820004 } [ 1 BEQ ] test-assembler
+B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
-{ HEX: 41830004 } [ 1 BO ] test-assembler
+B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
-{ HEX: 40830004 } [ 1 BNO ] test-assembler
+B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
-{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
+B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
-{ HEX: 4e800020 } [ BLR ] test-assembler
+B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
-{ HEX: 4e800021 } [ BLRL ] test-assembler
+B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
-{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
+B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
-{ HEX: 4e800420 } [ BCTR ] test-assembler
+B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
-{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
+B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
+B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
+B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
-{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
+B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
-{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
+B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
-{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
+B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
-{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
+B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
+B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
+B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
-{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
+B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
-{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
+B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
-{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
+B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
-{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
+B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
-{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
+B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
-{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
+B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
-{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
+B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
-{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
+B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
-{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
+B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
-{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
-{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
-{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
-{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
-{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
-{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
+B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
-{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
+B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
-{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
+B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
-{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
+B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler

basis/cpu/ppc/assembler/assembler.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.codegen.fixup kernel namespaces words
+USING: kernel namespaces words io.binary math math.order
-io.binary math math.order cpu.ppc.assembler.backend ;
+cpu.ppc.assembler.backend ;
 IN: cpu.ppc.assembler
 
 ! See the Motorola or IBM documentation for details. The opcode

basis/cpu/ppc/assembler/backend/backend.factor

@@ -1,11 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.codegen.fixup cpu.architecture
+USING:  kernel namespaces make sequences words math
-compiler.constants kernel namespaces make sequences words math
+math.bitwise io.binary parser lexer fry ;
-math.bitwise io.binary parser lexer ;
 IN: cpu.ppc.assembler.backend
 
-: insn ( operand opcode -- ) { 26 0 } bitfield , ;
+: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
 
 : a-insn ( d a b c xo rc opcode -- )
     [ { 0 1 6 11 16 21 } bitfield ] dip insn ;
@@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
 
 GENERIC# (B) 2 ( dest aa lk -- )
 M: integer (B) 18 i-insn ;
-M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
-M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
 
 GENERIC: BC ( a b c -- )
 M: integer BC 0 0 16 b-insn ;
-M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
-M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
 
 : CREATE-B ( -- word ) scan "B" prepend create-in ;
 
 SYNTAX: BC:
     CREATE-B scan-word scan-word
-    [ rot BC ] 2curry (( c -- )) define-declared ;
+    '[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
 
 SYNTAX: B:
     CREATE-B scan-word scan-word scan-word scan-word scan-word
-    [ b-insn ] curry curry curry curry curry
+    '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
-    (( bo -- )) define-declared ;

basis/cpu/ppc/bootstrap.factor

@@ -2,17 +2,15 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.ppc.assembler compiler.codegen.fixup compiler.units
-compiler.constants math math.private layouts words words.private
+compiler.constants math math.private layouts words
 vocabs slots.private locals.backend ;
 IN: bootstrap.ppc
 
 4 \ cell set
 big-endian on
 
-4 jit-code-format set
+CONSTANT: ds-reg 13
-
+CONSTANT: rs-reg 14
-CONSTANT: ds-reg 29
-CONSTANT: rs-reg 30
 
 : factor-area-size ( -- n ) 4 bootstrap-cells ;
 
@@ -23,73 +21,57 @@ CONSTANT: rs-reg 30
 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
 
 [
-    0 6 LOAD32
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
-    11 6 profile-count-offset LWZ
+    11 3 profile-count-offset LWZ
     11 11 1 tag-fixnum ADDI
-    11 6 profile-count-offset STW
+    11 3 profile-count-offset STW
-    11 6 word-code-offset LWZ
+    11 3 word-code-offset LWZ
     11 11 compiled-header-size ADDI
     11 MTCTR
     BCTR
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define
+] jit-profiling jit-define
 
 [
-    0 6 LOAD32
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
     0 MFLR
     1 1 stack-frame SUBI
-    6 1 xt-save STW
+    3 1 xt-save STW
-    stack-frame 6 LI
+    stack-frame 3 LI
-    6 1 next-save STW
+    3 1 next-save STW
     0 1 lr-save stack-frame + STW
-] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define
+] jit-prolog jit-define
 
 [
-    0 6 LOAD32
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
-    6 ds-reg 4 STWU
+    3 ds-reg 4 STWU
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define
+] jit-push-immediate jit-define
 
 [
-    0 6 LOAD32
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
-    7 6 0 LWZ
+    4 3 0 LWZ
-    1 7 0 STW
+    1 4 0 STW
-] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
-
+    3 MTCTR
-[
-    0 6 LOAD32
-    6 MTCTR
     BCTR
-] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
+] jit-primitive jit-define
 
-[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
+[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
 
-[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
+[
+    0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
+    0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
+] jit-word-jump jit-define
+
+[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
 
 [
     3 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
     0 3 \ f tag-number CMPI
     2 BEQ
-    0 B
+    0 B rc-relative-ppc-3 rt-xt jit-rel
-] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define
+    0 B rc-relative-ppc-3 rt-xt jit-rel
-
+] jit-if jit-define
-[
-    0 B
-] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define
-
-: jit-jump-quot ( -- )
-    4 3 quot-xt-offset LWZ
-    4 MTCTR
-    BCTR ;
-
-[
-    0 3 LOAD32
-    6 ds-reg 0 LWZ
-    6 6 1 SRAWI
-    3 3 6 ADD
-    3 3 array-start-offset LWZ
-    ds-reg dup 4 SUBI
-    jit-jump-quot
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define
 
 : jit->r ( -- )
     4 ds-reg 0 LWZ
@@ -139,46 +121,142 @@ CONSTANT: rs-reg 30
 
 [
     jit->r
-    0 BL
+    0 BL rc-relative-ppc-3 rt-xt jit-rel
     jit-r>
-] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define
+] jit-dip jit-define
 
 [
     jit-2>r
-    0 BL
+    0 BL rc-relative-ppc-3 rt-xt jit-rel
     jit-2r>
-] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define
+] jit-2dip jit-define
 
 [
     jit-3>r
-    0 BL
+    0 BL rc-relative-ppc-3 rt-xt jit-rel
     jit-3r>
-] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define
+] jit-3dip jit-define
+
+: prepare-(execute) ( -- operand )
+    3 ds-reg 0 LWZ
+    ds-reg dup 4 SUBI
+    4 3 word-xt-offset LWZ
+    4 ;
+
+[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
+
+[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
 
 [
     0 1 lr-save stack-frame + LWZ
     1 1 stack-frame ADDI
     0 MTLR
-] f f f jit-epilog jit-define
+] jit-epilog jit-define
 
-[ BLR ] f f f jit-return jit-define
+[ BLR ] jit-return jit-define
 
-! Sub-primitives
+! ! ! Polymorphic inline caches
+
+! Don't touch r6 here; it's used to pass the tail call site
+! address for tail PICs
+
+! Load a value from a stack position
+[
+    4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
+] pic-load jit-define
+
+! Tag
+: load-tag ( -- )
+    4 4 tag-mask get ANDI
+    4 4 tag-bits get SLWI ;
+
+[ load-tag ] pic-tag jit-define
+
+! Hi-tag
+[
+    3 4 MR
+    load-tag
+    0 4 object tag-number tag-fixnum CMPI
+    2 BNE
+    4 3 object tag-number neg LWZ
+] pic-hi-tag jit-define
+
+! Tuple
+[
+    3 4 MR
+    load-tag
+    0 4 tuple tag-number tag-fixnum CMPI
+    2 BNE
+    4 3 tuple tag-number neg bootstrap-cell + LWZ
+] pic-tuple jit-define
+
+! Hi-tag and tuple
+[
+    3 4 MR
+    load-tag
+    ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
+    0 4 BIN: 110 tag-fixnum CMPI
+    5 BLT
+    ! Untag r3
+    3 3 0 0 31 tag-bits get - RLWINM
+    ! Set r4 to 0 for objects, and bootstrap-cell for tuples
+    4 4 1 tag-fixnum ANDI
+    4 4 1 SRAWI
+    ! Load header cell or tuple layout cell
+    4 4 3 LWZX
+] pic-hi-tag-tuple jit-define
+
+[
+    0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
+] pic-check-tag jit-define
+
+[
+    0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    4 0 5 CMP
+] pic-check jit-define
+
+[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
+
+! ! ! Megamorphic caches
+
+[
+    ! cache = ...
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    ! key = class
+    5 4 MR
+    ! key &= cache.length - 1
+    5 5 mega-cache-size get 1- bootstrap-cell * ANDI
+    ! cache += array-start-offset
+    3 3 array-start-offset ADDI
+    ! cache += key
+    3 3 5 ADD
+    ! if(get(cache) == class)
+    6 3 0 LWZ
+    6 0 4 CMP
+    10 BNE
+    ! megamorphic_cache_hits++
+    0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
+    5 4 0 LWZ
+    5 5 1 ADDI
+    5 4 0 STW
+    ! ... goto get(cache + bootstrap-cell)
+    3 3 4 LWZ
+    3 3 word-xt-offset LWZ
+    3 MTCTR
+    BCTR
+    ! fall-through on miss
+] mega-lookup jit-define
+
+! ! ! Sub-primitives
 
 ! Quotations and words
 [
     3 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
-    jit-jump-quot
+    4 3 quot-xt-offset LWZ
-] f f f \ (call) define-sub-primitive
-
-[
-    3 ds-reg 0 LWZ
-    ds-reg dup 4 SUBI
-    4 3 word-xt-offset LWZ
     4 MTCTR
     BCTR
-] f f f \ (execute) define-sub-primitive
+] \ (call) define-sub-primitive
 
 ! Objects
 [
@@ -186,7 +264,7 @@ CONSTANT: rs-reg 30
     3 3 tag-mask get ANDI
     3 3 tag-bits get SLWI
     3 ds-reg 0 STW
-] f f f \ tag define-sub-primitive
+] \ tag define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -195,25 +273,25 @@ CONSTANT: rs-reg 30
     4 4 0 0 31 tag-bits get - RLWINM
     4 3 3 LWZX
     3 ds-reg 0 STW
-] f f f \ slot define-sub-primitive
+] \ slot define-sub-primitive
 
 ! Shufflers
 [
     ds-reg dup 4 SUBI
-] f f f \ drop define-sub-primitive
+] \ drop define-sub-primitive
 
 [
     ds-reg dup 8 SUBI
-] f f f \ 2drop define-sub-primitive
+] \ 2drop define-sub-primitive
 
 [
     ds-reg dup 12 SUBI
-] f f f \ 3drop define-sub-primitive
+] \ 3drop define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     3 ds-reg 4 STWU
-] f f f \ dup define-sub-primitive
+] \ dup define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -221,7 +299,7 @@ CONSTANT: rs-reg 30
     ds-reg dup 8 ADDI
     3 ds-reg 0 STW
     4 ds-reg -4 STW
-] f f f \ 2dup define-sub-primitive
+] \ 2dup define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -231,36 +309,36 @@ CONSTANT: rs-reg 30
     3 ds-reg 0 STW
     4 ds-reg -4 STW
     5 ds-reg -8 STW
-] f f f \ 3dup define-sub-primitive
+] \ 3dup define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
     3 ds-reg 0 STW
-] f f f \ nip define-sub-primitive
+] \ nip define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     ds-reg dup 8 SUBI
     3 ds-reg 0 STW
-] f f f \ 2nip define-sub-primitive
+] \ 2nip define-sub-primitive
 
 [
     3 ds-reg -4 LWZ
     3 ds-reg 4 STWU
-] f f f \ over define-sub-primitive
+] \ over define-sub-primitive
 
 [
     3 ds-reg -8 LWZ
     3 ds-reg 4 STWU
-] f f f \ pick define-sub-primitive
+] \ pick define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     4 ds-reg -4 LWZ
     4 ds-reg 0 STW
     3 ds-reg 4 STWU
-] f f f \ dupd define-sub-primitive
+] \ dupd define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -268,21 +346,21 @@ CONSTANT: rs-reg 30
     3 ds-reg 4 STWU
     4 ds-reg -4 STW
     3 ds-reg -8 STW
-] f f f \ tuck define-sub-primitive
+] \ tuck define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     4 ds-reg -4 LWZ
     3 ds-reg -4 STW
     4 ds-reg 0 STW
-] f f f \ swap define-sub-primitive
+] \ swap define-sub-primitive
 
 [
     3 ds-reg -4 LWZ
     4 ds-reg -8 LWZ
     3 ds-reg -8 STW
     4 ds-reg -4 STW
-] f f f \ swapd define-sub-primitive
+] \ swapd define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -291,7 +369,7 @@ CONSTANT: rs-reg 30
     4 ds-reg -8 STW
     3 ds-reg -4 STW
     5 ds-reg 0 STW
-] f f f \ rot define-sub-primitive
+] \ rot define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -300,13 +378,13 @@ CONSTANT: rs-reg 30
     3 ds-reg -8 STW
     5 ds-reg -4 STW
     4 ds-reg 0 STW
-] f f f \ -rot define-sub-primitive
+] \ -rot define-sub-primitive
 
-[ jit->r ] f f f \ load-local define-sub-primitive
+[ jit->r ] \ load-local define-sub-primitive
 
 ! Comparisons
 : jit-compare ( insn -- )
-    0 3 LOAD32
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
     4 ds-reg 0 LWZ
     5 ds-reg -4 LWZU
     5 0 4 CMP
@@ -315,8 +393,7 @@ CONSTANT: rs-reg 30
     3 ds-reg 0 STW ;
 
 : define-jit-compare ( insn word -- )
-    [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip
+    [ [ jit-compare ] curry ] dip define-sub-primitive ;
-    define-sub-primitive ;
 
 \ BEQ \ eq? define-jit-compare
 \ BGE \ fixnum>= define-jit-compare
@@ -336,7 +413,7 @@ CONSTANT: rs-reg 30
     2 BNE
     1 tag-fixnum 4 LI
     4 ds-reg 0 STW
-] f f f \ both-fixnums? define-sub-primitive
+] \ both-fixnums? define-sub-primitive
 
 : jit-math ( insn -- )
     3 ds-reg 0 LWZ
@@ -344,9 +421,9 @@ CONSTANT: rs-reg 30
     [ 5 3 4 ] dip execute( dst src1 src2 -- )
     5 ds-reg 0 STW ;
 
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
 
-[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive
+[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -354,20 +431,20 @@ CONSTANT: rs-reg 30
     4 4 tag-bits get SRAWI
     5 3 4 MULLW
     5 ds-reg 0 STW
-] f f f \ fixnum*fast define-sub-primitive
+] \ fixnum*fast define-sub-primitive
 
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
 
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
 
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     3 3 NOT
     3 3 tag-mask get XORI
     3 ds-reg 0 STW
-] f f f \ fixnum-bitnot define-sub-primitive
+] \ fixnum-bitnot define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -382,7 +459,7 @@ CONSTANT: rs-reg 30
     2 BGT
     5 7 MR
     5 ds-reg 0 STW
-] f f f \ fixnum-shift-fast define-sub-primitive
+] \ fixnum-shift-fast define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -392,7 +469,7 @@ CONSTANT: rs-reg 30
     6 5 3 MULLW
     7 6 4 SUBF
     7 ds-reg 0 STW
-] f f f \ fixnum-mod define-sub-primitive
+] \ fixnum-mod define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -401,7 +478,7 @@ CONSTANT: rs-reg 30
     5 4 3 DIVW
     5 5 tag-bits get SLWI
     5 ds-reg 0 STW
-] f f f \ fixnum/i-fast define-sub-primitive
+] \ fixnum/i-fast define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -412,20 +489,20 @@ CONSTANT: rs-reg 30
     5 5 tag-bits get SLWI
     5 ds-reg -4 STW
     7 ds-reg 0 STW
-] f f f \ fixnum/mod-fast define-sub-primitive
+] \ fixnum/mod-fast define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     3 3 1 SRAWI
     rs-reg 3 3 LWZX
     3 ds-reg 0 STW
-] f f f \ get-local define-sub-primitive
+] \ get-local define-sub-primitive
 
 [
     3 ds-reg 0 LWZ
     ds-reg ds-reg 4 SUBI
     3 3 1 SRAWI
     rs-reg 3 rs-reg SUBF
-] f f f \ drop-locals define-sub-primitive
+] \ drop-locals define-sub-primitive
 
 [ "bootstrap.ppc" forget-vocab ] with-compilation-unit

basis/cpu/ppc/ppc.factor

@@ -1,33 +1,39 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
-alien alien.c-types cpu.architecture cpu.ppc.assembler
+alien alien.c-types literals cpu.architecture cpu.ppc.assembler
-compiler.cfg.registers compiler.cfg.instructions
+cpu.ppc.assembler.backend literals compiler.cfg.registers
-compiler.constants compiler.codegen compiler.codegen.fixup
+compiler.cfg.instructions compiler.constants compiler.codegen
-compiler.cfg.intrinsics compiler.cfg.stack-frame ;
+compiler.codegen.fixup compiler.cfg.intrinsics
+compiler.cfg.stack-frame ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
-! r2-r27: integer vregs
+! r2-r12: integer vregs
-! r28: integer scratch
+! r15-r29
-! r29: data stack
+! r30: integer scratch
-! r30: retain stack
 ! f0-f29: float vregs
-! f30, f31: float scratch
+! f30: float scratch
+
+! Add some methods to the assembler that are useful to us
+M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
+M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
 
 enable-float-intrinsics
 
-<< \ ##integer>float t frame-required? set-word-prop
+<<
-\ ##float>integer t frame-required? set-word-prop >>
+\ ##integer>float t frame-required? set-word-prop
+\ ##float>integer t frame-required? set-word-prop
+>>
 
 M: ppc machine-registers
     {
-        { int-regs T{ range f 2 26 1 } }
+        { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
-        { double-float-regs T{ range f 0 29 1 } }
+        { double-float-regs $[ 0 29 [a,b] ] }
     } ;
 
-CONSTANT: scratch-reg 28
+CONSTANT: scratch-reg 30
 CONSTANT: fp-scratch-reg 30
 
 M: ppc two-operand? f ;
@@ -40,8 +46,8 @@ M: ppc %load-reference ( reg obj -- )
 M: ppc %alien-global ( register symbol dll -- )
     [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
 
-CONSTANT: ds-reg 29
+CONSTANT: ds-reg 13
-CONSTANT: rs-reg 30
+CONSTANT: rs-reg 14
 
 GENERIC: loc-reg ( loc -- reg )
 
@@ -108,7 +114,12 @@ M: ppc stack-frame-size ( stack-frame -- i )
     factor-area-size +
     4 cells align ;
 
-M: ppc %call ( label -- ) BL ;
+M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
+
+M: ppc %jump ( word -- )
+    0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
+    0 B rc-relative-ppc-3 rel-word-pic-tail ;
+
 M: ppc %jump-label ( label -- ) B ;
 M: ppc %return ( -- ) BLR ;
 
@@ -120,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- )
     BCTR ;
 
 M: ppc %dispatch-label ( word -- )
-    0 , rc-absolute-cell rel-word ;
+    B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
 
 :: (%slot) ( obj slot tag temp -- reg offset )
     temp slot obj ADD
@@ -641,10 +652,10 @@ M: ppc %alien-callback ( quot -- )
 
 M: ppc %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
-    13 3 MR ;
+    15 3 MR ;
 
 M: ppc %alien-indirect ( -- )
-    13 MTLR BLRL ;
+    15 MTLR BLRL ;
 
 M: ppc %callback-value ( ctype -- )
     ! Save top of data stack
@@ -702,3 +713,4 @@ USE: vocabs.loader
 } cond
 
 "complex-double" c-type t >>return-in-registers? drop
+"bool" c-type 4 >>size 4 >>align drop

basis/cpu/x86/32/32.factor

@@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- )
 M: x86.32 param-reg-1 EAX ;
 M: x86.32 param-reg-2 EDX ;
 
+M: x86.32 pic-tail-reg EBX ;
+
 M: x86.32 reserved-area-size 0 ;
 
-M: x86.32 %alien-invoke (CALL) rel-dlsym ;
+M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
 
-M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
+M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
 
 M: x86.32 return-struct-in-registers? ( c-type -- ? )
     c-type
@@ -309,7 +311,7 @@ FUNCTION: bool check_sse2 ( ) ;
     check_sse2 ;
 
 "-no-sse2" (command-line) member? [
-    optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
+    [ { check_sse2 } compile ] with-optimizer
 
     "Checking if your CPU supports SSE2..." print flush
     sse2? [

basis/cpu/x86/32/bootstrap.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
 cpu.x86.assembler layouts vocabs parser compiler.constants ;
@@ -22,13 +22,13 @@ IN: bootstrap.x86
 : rex-length ( -- n ) 0 ;
 
 [
-    temp0 0 [] MOV                              ! load stack_chain
+    ! load stack_chain
-    temp0 [] stack-reg MOV                      ! save stack pointer
+    temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
-] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
+    ! save stack pointer
-
+    temp0 [] stack-reg MOV
-[
+    ! call the primitive
-    (JMP) drop
+    0 JMP rc-relative rt-primitive jit-rel
-] rc-relative rt-primitive 1 jit-primitive jit-define
+] jit-primitive jit-define
 
 << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
 call

basis/cpu/x86/64/64.factor

@@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ;
 M: x86.64 param-reg-2 int-regs param-regs second ;
 : param-reg-3 ( -- reg ) int-regs param-regs third ; inline
 
+M: x86.64 pic-tail-reg RBX ;
+
 M: int-regs return-reg drop RAX ;
 M: float-regs return-reg drop XMM0 ;
 

basis/cpu/x86/64/bootstrap.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
 cpu.x86.assembler layouts vocabs parser compiler.constants math ;
@@ -20,15 +20,16 @@ IN: bootstrap.x86
 : rex-length ( -- n ) 1 ;
 
 [
-    temp0 0 MOV                                 ! load stack_chain
+    ! load stack_chain
+    temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
     temp0 temp0 [] MOV
-    temp0 [] stack-reg MOV                      ! save stack pointer
+    ! save stack pointer
-] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
+    temp0 [] stack-reg MOV
-
+    ! load XT
-[
+    temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
-    temp1 0 MOV                                 ! load XT
+    ! go
-    temp1 JMP                                   ! go
+    temp1 JMP
-] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
+] jit-primitive jit-define
 
 << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
 call

basis/cpu/x86/assembler/assembler-tests.factor

@@ -62,3 +62,5 @@ IN: cpu.x86.assembler.tests
 [ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
+
+[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test

basis/cpu/x86/assembler/assembler.factor

@@ -1,12 +1,11 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays cpu.architecture compiler.constants
+USING: arrays io.binary kernel combinators
-compiler.codegen.fixup io.binary kernel combinators
+kernel.private math namespaces make sequences words system layouts
-kernel.private math namespaces make sequences words system
+math.order accessors cpu.x86.assembler.syntax ;
-layouts math.order accessors cpu.x86.assembler.syntax ;
 IN: cpu.x86.assembler
 
-! A postfix assembler for x86 and AMD64.
+! A postfix assembler for x86-32 and x86-64.
 
 ! In 32-bit mode, { 1234 } is absolute indirect addressing.
 ! In 64-bit mode, { 1234 } is RIP-relative.
@@ -296,35 +295,23 @@ M: operand (MOV-I)
     { BIN: 000 t HEX: c6 }
     pick byte? [ immediate-1 ] [ immediate-4 ] if ;
 
-PREDICATE: callable < word register? not ;
-
 GENERIC: MOV ( dst src -- )
 M: immediate MOV swap (MOV-I) ;
-M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
 M: operand MOV HEX: 88 2-operand ;
 
 : LEA ( dst src -- ) swap HEX: 8d 2-operand ;
 
 ! Control flow
 GENERIC: JMP ( op -- )
-: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
+M: integer JMP HEX: e9 , 4, ;
-M: f JMP (JMP) 2drop ;
-M: callable JMP (JMP) rel-word ;
-M: label JMP (JMP) label-fixup ;
 M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 
 GENERIC: CALL ( op -- )
-: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
+M: integer CALL HEX: e8 , 4, ;
-M: f CALL (CALL) 2drop ;
-M: callable CALL (CALL) rel-word ;
-M: label CALL (CALL) label-fixup ;
 M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
 
 GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
+M: integer JUMPcc extended-opcode, 4, ;
-M: f JUMPcc nip (JUMPcc) drop ;
-M: callable JUMPcc (JUMPcc) rel-word ;
-M: label JUMPcc (JUMPcc) label-fixup ;
 
 : JO  ( dst -- ) HEX: 80 JUMPcc ;
 : JNO ( dst -- ) HEX: 81 JUMPcc ;
@@ -382,6 +369,10 @@ GENERIC: CMP ( dst src -- )
 M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
 M: operand CMP OCT: 070 2-operand ;
 
+GENERIC: TEST ( dst src -- )
+M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
+M: operand TEST OCT: 204 2-operand ;
+
 : XCHG ( dst src -- ) OCT: 207 2-operand ;
 
 : BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;

basis/cpu/x86/bootstrap.factor

@@ -1,18 +1,16 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.x86.assembler layouts compiler.units math
 math.private compiler.constants vocabs slots.private words
-words.private locals.backend ;
+locals.backend make sequences combinators arrays ;
 IN: bootstrap.x86
 
 big-endian off
 
-1 jit-code-format set
-
 [
     ! Load word
-    temp0 0 MOV
+    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
     ! Bump profiling counter
     temp0 profile-count-offset [+] 1 tag-fixnum ADD
     ! Load word->code
@@ -21,35 +19,40 @@ big-endian off
     temp0 compiled-header-size ADD
     ! Jump to XT
     temp0 JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
+] jit-profiling jit-define
 
 [
     ! load XT
-    temp0 0 MOV
+    temp0 0 MOV rc-absolute-cell rt-this jit-rel
     ! save stack frame size
     stack-frame-size PUSH
     ! push XT
     temp0 PUSH
     ! alignment
     stack-reg stack-frame-size 3 bootstrap-cells - SUB
-] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
+] jit-prolog jit-define
 
 [
     ! load literal
-    temp0 0 MOV
+    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
     ! increment datastack pointer
     ds-reg bootstrap-cell ADD
     ! store literal on datastack
     ds-reg [] temp0 MOV
-] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
+] jit-push-immediate jit-define
 
 [
-    f JMP
+    temp3 0 MOV rc-absolute-cell rt-here jit-rel
-] rc-relative rt-xt 1 jit-word-jump jit-define
+    0 JMP rc-relative rt-xt-pic-tail jit-rel
+] jit-word-jump jit-define
 
 [
-    f CALL
+    0 CALL rc-relative rt-xt-pic jit-rel
-] rc-relative rt-xt 1 jit-word-call jit-define
+] jit-word-call jit-define
+
+[
+    0 JMP rc-relative rt-xt jit-rel
+] jit-word-special jit-define
 
 [
     ! load boolean
@@ -59,31 +62,10 @@ big-endian off
     ! compare boolean with f
     temp0 \ f tag-number CMP
     ! jump to true branch if not equal
-    f JNE
+    0 JNE rc-relative rt-xt jit-rel
-] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
-
-[
     ! jump to false branch if equal
-    f JMP
+    0 JMP rc-relative rt-xt jit-rel
-] rc-relative rt-xt 1 jit-if-2 jit-define
+] jit-if jit-define
-
-[
-    ! load dispatch table
-    temp1 0 MOV
-    ! load index
-    temp0 ds-reg [] MOV
-    ! turn it into an array offset
-    fixnum>slot@
-    ! pop index
-    ds-reg bootstrap-cell SUB
-    ! compute quotation location
-    temp0 temp1 ADD
-    ! load quotation
-    arg temp0 array-start-offset [+] MOV
-    ! execute branch. the quot must be in arg, since it might
-    ! not be compiled yet
-    arg quot-xt-offset [+] JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
 
 : jit->r ( -- )
     rs-reg bootstrap-cell ADD
@@ -135,30 +117,133 @@ big-endian off
 
 [
     jit->r
-    f CALL
+    0 CALL rc-relative rt-xt jit-rel
     jit-r>
-] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
+] jit-dip jit-define
 
 [
     jit-2>r
-    f CALL
+    0 CALL rc-relative rt-xt jit-rel
     jit-2r>
-] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
+] jit-2dip jit-define
 
 [
     jit-3>r
-    f CALL
+    0 CALL rc-relative rt-xt jit-rel
     jit-3r>
-] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
+] jit-3dip jit-define
+
+: prepare-(execute) ( -- operand )
+    ! load from stack
+    temp0 ds-reg [] MOV
+    ! pop stack
+    ds-reg bootstrap-cell SUB
+    ! execute word
+    temp0 word-xt-offset [+] ;
+
+[ prepare-(execute) JMP ] jit-execute-jump jit-define
+
+[ prepare-(execute) CALL ] jit-execute-call jit-define
 
 [
     ! unwind stack frame
     stack-reg stack-frame-size bootstrap-cell - ADD
-] f f f jit-epilog jit-define
+] jit-epilog jit-define
 
-[ 0 RET ] f f f jit-return jit-define
+[ 0 RET ] jit-return jit-define
 
-! Sub-primitives
+! ! ! Polymorphic inline caches
+
+! The PIC and megamorphic code stubs are not permitted to touch temp3.
+
+! Load a value from a stack position
+[
+    temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel
+] pic-load jit-define
+
+! Tag
+: load-tag ( -- )
+    temp1 tag-mask get AND
+    temp1 tag-bits get SHL ;
+
+[ load-tag ] pic-tag jit-define
+
+! The 'make' trick lets us compute the jump distance for the
+! conditional branches there
+
+! Hi-tag
+[
+    temp0 temp1 MOV
+    load-tag
+    temp1 object tag-number tag-fixnum CMP
+    [ temp1 temp0 object tag-number neg [+] MOV ] { } make
+    [ length JNE ] [ % ] bi
+] pic-hi-tag jit-define
+
+! Tuple
+[
+    temp0 temp1 MOV
+    load-tag
+    temp1 tuple tag-number tag-fixnum CMP
+    [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
+    [ length JNE ] [ % ] bi
+] pic-tuple jit-define
+
+! Hi-tag and tuple
+[
+    temp0 temp1 MOV
+    load-tag
+    ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
+    temp1 BIN: 110 tag-fixnum CMP
+    [
+        ! Untag temp0
+        temp0 tag-mask get bitnot AND
+        ! Set temp1 to 0 for objects, and bootstrap-cell for tuples
+        temp1 1 tag-fixnum AND
+        bootstrap-cell 4 = [ temp1 1 SHR ] when
+        ! Load header cell or tuple layout cell
+        temp1 temp0 temp1 [+] MOV
+    ] [ ] make [ length JL ] [ % ] bi
+] pic-hi-tag-tuple jit-define
+
+[
+    temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
+] pic-check-tag jit-define
+
+[
+    temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
+    temp1 temp2 CMP
+] pic-check jit-define
+
+[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
+
+! ! ! Megamorphic caches
+
+[
+    ! cache = ...
+    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
+    ! key = class
+    temp2 temp1 MOV
+    bootstrap-cell 8 = [ temp2 1 SHL ] when
+    ! key &= cache.length - 1
+    temp2 mega-cache-size get 1- bootstrap-cell * AND
+    ! cache += array-start-offset
+    temp0 array-start-offset ADD
+    ! cache += key
+    temp0 temp2 ADD
+    ! if(get(cache) == class)
+    temp0 [] temp1 CMP
+    bootstrap-cell 4 = 14 22 ? JNE ! Yuck!
+    ! megamorphic_cache_hits++
+    temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
+    temp1 [] 1 ADD
+    ! goto get(cache + bootstrap-cell)
+    temp0 temp0 bootstrap-cell [+] MOV
+    temp0 word-xt-offset [+] JMP
+    ! fall-through on miss
+] mega-lookup jit-define
+
+! ! ! Sub-primitives
 
 ! Quotations and words
 [
@@ -168,16 +253,7 @@ big-endian off
     ds-reg bootstrap-cell SUB
     ! call quotation
     arg quot-xt-offset [+] JMP
-] f f f \ (call) define-sub-primitive
+] \ (call) define-sub-primitive
-
-[
-    ! load from stack
-    temp0 ds-reg [] MOV
-    ! pop stack
-    ds-reg bootstrap-cell SUB
-    ! execute word
-    temp0 word-xt-offset [+] JMP
-] f f f \ (execute) define-sub-primitive
 
 ! Objects
 [
@@ -189,7 +265,7 @@ big-endian off
     temp0 tag-bits get SHL
     ! push to stack
     ds-reg [] temp0 MOV
-] f f f \ tag define-sub-primitive
+] \ tag define-sub-primitive
 
 [
     ! load slot number
@@ -207,26 +283,26 @@ big-endian off
     temp0 temp1 temp0 [+] MOV
     ! push to stack
     ds-reg [] temp0 MOV
-] f f f \ slot define-sub-primitive
+] \ slot define-sub-primitive
 
 ! Shufflers
 [
     ds-reg bootstrap-cell SUB
-] f f f \ drop define-sub-primitive
+] \ drop define-sub-primitive
 
 [
     ds-reg 2 bootstrap-cells SUB
-] f f f \ 2drop define-sub-primitive
+] \ 2drop define-sub-primitive
 
 [
     ds-reg 3 bootstrap-cells SUB
-] f f f \ 3drop define-sub-primitive
+] \ 3drop define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
     ds-reg bootstrap-cell ADD
     ds-reg [] temp0 MOV
-] f f f \ dup define-sub-primitive
+] \ dup define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -234,7 +310,7 @@ big-endian off
     ds-reg 2 bootstrap-cells ADD
     ds-reg [] temp0 MOV
     ds-reg bootstrap-cell neg [+] temp1 MOV
-] f f f \ 2dup define-sub-primitive
+] \ 2dup define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -244,31 +320,31 @@ big-endian off
     ds-reg [] temp0 MOV
     ds-reg -1 bootstrap-cells [+] temp1 MOV
     ds-reg -2 bootstrap-cells [+] temp3 MOV
-] f f f \ 3dup define-sub-primitive
+] \ 3dup define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
     ds-reg bootstrap-cell SUB
     ds-reg [] temp0 MOV
-] f f f \ nip define-sub-primitive
+] \ nip define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
     ds-reg 2 bootstrap-cells SUB
     ds-reg [] temp0 MOV
-] f f f \ 2nip define-sub-primitive
+] \ 2nip define-sub-primitive
 
 [
     temp0 ds-reg -1 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
     ds-reg [] temp0 MOV
-] f f f \ over define-sub-primitive
+] \ over define-sub-primitive
 
 [
     temp0 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
     ds-reg [] temp0 MOV
-] f f f \ pick define-sub-primitive
+] \ pick define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -276,7 +352,7 @@ big-endian off
     ds-reg [] temp1 MOV
     ds-reg bootstrap-cell ADD
     ds-reg [] temp0 MOV
-] f f f \ dupd define-sub-primitive
+] \ dupd define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -285,21 +361,21 @@ big-endian off
     ds-reg [] temp0 MOV
     ds-reg -1 bootstrap-cells [+] temp1 MOV
     ds-reg -2 bootstrap-cells [+] temp0 MOV
-] f f f \ tuck define-sub-primitive
+] \ tuck define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
     temp1 ds-reg bootstrap-cell neg [+] MOV
     ds-reg bootstrap-cell neg [+] temp0 MOV
     ds-reg [] temp1 MOV
-] f f f \ swap define-sub-primitive
+] \ swap define-sub-primitive
 
 [
     temp0 ds-reg -1 bootstrap-cells [+] MOV
     temp1 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg -2 bootstrap-cells [+] temp0 MOV
     ds-reg -1 bootstrap-cells [+] temp1 MOV
-] f f f \ swapd define-sub-primitive
+] \ swapd define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -308,7 +384,7 @@ big-endian off
     ds-reg -2 bootstrap-cells [+] temp1 MOV
     ds-reg -1 bootstrap-cells [+] temp0 MOV
     ds-reg [] temp3 MOV
-] f f f \ rot define-sub-primitive
+] \ rot define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -317,14 +393,14 @@ big-endian off
     ds-reg -2 bootstrap-cells [+] temp0 MOV
     ds-reg -1 bootstrap-cells [+] temp3 MOV
     ds-reg [] temp1 MOV
-] f f f \ -rot define-sub-primitive
+] \ -rot define-sub-primitive
 
-[ jit->r ] f f f \ load-local define-sub-primitive
+[ jit->r ] \ load-local define-sub-primitive
 
 ! Comparisons
 : jit-compare ( insn -- )
     ! load t
-    temp3 0 MOV
+    temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
     ! load f
     temp1 \ f tag-number MOV
     ! load first value
@@ -339,8 +415,7 @@ big-endian off
     ds-reg [] temp1 MOV ;
 
 : define-jit-compare ( insn word -- )
-    [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
+    [ [ jit-compare ] curry ] dip define-sub-primitive ;
-    define-sub-primitive ;
 
 \ CMOVE \ eq? define-jit-compare
 \ CMOVGE \ fixnum>= define-jit-compare
@@ -357,9 +432,9 @@ big-endian off
     ! compute result
     [ ds-reg [] temp0 ] dip execute( dst src -- ) ;
 
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
 
-[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
+[ \ SUB jit-math ] \ fixnum-fast define-sub-primitive
 
 [
     ! load second input
@@ -374,20 +449,20 @@ big-endian off
     temp0 temp1 IMUL2
     ! push result
     ds-reg [] temp1 MOV
-] f f f \ fixnum*fast define-sub-primitive
+] \ fixnum*fast define-sub-primitive
 
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
 
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
 
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
 
 [
     ! complement
     ds-reg [] NOT
     ! clear tag bits
     ds-reg [] tag-mask get XOR
-] f f f \ fixnum-bitnot define-sub-primitive
+] \ fixnum-bitnot define-sub-primitive
 
 [
     ! load shift count
@@ -411,7 +486,7 @@ big-endian off
     temp1 temp3 CMOVGE
     ! push to stack
     ds-reg [] temp1 MOV
-] f f f \ fixnum-shift-fast define-sub-primitive
+] \ fixnum-shift-fast define-sub-primitive
 
 : jit-fixnum-/mod ( -- )
     ! load second parameter
@@ -431,7 +506,7 @@ big-endian off
     ds-reg bootstrap-cell SUB
     ! push to stack
     ds-reg [] mod-arg MOV
-] f f f \ fixnum-mod define-sub-primitive
+] \ fixnum-mod define-sub-primitive
 
 [
     jit-fixnum-/mod
@@ -441,7 +516,7 @@ big-endian off
     div-arg tag-bits get SHL
     ! push to stack
     ds-reg [] div-arg MOV
-] f f f \ fixnum/i-fast define-sub-primitive
+] \ fixnum/i-fast define-sub-primitive
 
 [
     jit-fixnum-/mod
@@ -450,7 +525,7 @@ big-endian off
     ! push to stack
     ds-reg [] mod-arg MOV
     ds-reg bootstrap-cell neg [+] div-arg MOV
-] f f f \ fixnum/mod-fast define-sub-primitive
+] \ fixnum/mod-fast define-sub-primitive
 
 [
     temp0 ds-reg [] MOV
@@ -461,7 +536,7 @@ big-endian off
     temp1 1 tag-fixnum MOV
     temp0 temp1 CMOVE
     ds-reg [] temp0 MOV
-] f f f \ both-fixnums? define-sub-primitive
+] \ both-fixnums? define-sub-primitive
 
 [
     ! load local number
@@ -472,7 +547,7 @@ big-endian off
     temp0 rs-reg temp0 [+] MOV
     ! push to stack
     ds-reg [] temp0 MOV
-] f f f \ get-local define-sub-primitive
+] \ get-local define-sub-primitive
 
 [
     ! load local count
@@ -483,6 +558,6 @@ big-endian off
     fixnum>slot@
     ! decrement retain stack pointer
     rs-reg temp0 SUB
-] f f f \ drop-locals define-sub-primitive
+] \ drop-locals define-sub-primitive
 
 [ "bootstrap.x86" forget-vocab ] with-compilation-unit

basis/cpu/x86/x86.factor

@@ -11,6 +11,10 @@ IN: cpu.x86
 
 << enable-fixnum-log2 >>
 
+! Add some methods to the assembler to be more useful to the backend
+M: label JMP 0 JMP rc-relative label-fixup ;
+M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
+
 M: x86 two-operand? t ;
 
 HOOK: temp-reg-1 cpu ( -- reg )
@@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg )
 HOOK: param-reg-1 cpu ( -- reg )
 HOOK: param-reg-2 cpu ( -- reg )
 
+HOOK: pic-tail-reg cpu ( -- reg )
+
 M: x86 %load-immediate MOV ;
 
 M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
@@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i )
     reserved-area-size +
     align-stack ;
 
-M: x86 %call ( label -- ) CALL ;
+M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
-M: x86 %jump-label ( label -- ) JMP ;
+
+: xt-tail-pic-offset ( -- n )
+    #! See the comment in vm/cpu-x86.hpp
+    cell 4 + 1 + ; inline
+
+M: x86 %jump ( word -- )
+    pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
+    0 JMP rc-relative rel-word-pic-tail ;
+
+M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
+
 M: x86 %return ( -- ) 0 RET ;
 
 : code-alignment ( align -- n )

basis/debugger/debugger-docs.factor

@@ -1,6 +1,6 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations io.files.private listener
+help generic.single continuations io.files.private listener
 alien.libraries ;
 IN: debugger
 

basis/debugger/debugger.factor

@@ -1,14 +1,13 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: slots arrays definitions generic hashtables summary io
+USING: slots arrays definitions generic hashtables summary io kernel
-kernel math namespaces make prettyprint prettyprint.config
+math namespaces make prettyprint prettyprint.config sequences assocs
-sequences assocs sequences.private strings io.styles
+sequences.private strings io.styles io.pathnames vectors words system
-io.pathnames vectors words system splitting math.parser
+splitting math.parser classes.mixin classes.tuple continuations
-classes.mixin classes.tuple continuations continuations.private
+continuations.private combinators generic.math classes.builtin classes
-combinators generic.math classes.builtin classes compiler.units
+compiler.units generic.standard generic.single vocabs init
-generic.standard vocabs init kernel.private io.encodings
+kernel.private io.encodings accessors math.order destructors
-accessors math.order destructors source-files parser
+source-files parser classes.tuple.parser effects.parser lexer
-classes.tuple.parser effects.parser lexer
 generic.parser strings.parser vocabs.loader vocabs.parser see
 source-files.errors ;
 IN: debugger
@@ -17,6 +16,7 @@ GENERIC: error. ( error -- )
 GENERIC: error-help ( error -- topic )
 
 M: object error. . ;
+
 M: object error-help drop f ;
 
 M: tuple error-help class ;
@@ -77,7 +77,7 @@ M: string error. print ;
     "Object did not survive image save/load: " write third . ;
 
 : io-error. ( error -- )
-    "I/O error: " write third print ;
+    "I/O error #" write third . ;
 
 : type-check-error. ( obj -- )
     "Type check error" print
@@ -98,9 +98,7 @@ HOOK: signal-error. os ( obj -- )
     "Cannot convert to C string: " write third . ;
 
 : ffi-error. ( obj -- )
-    "FFI: " write
+    "FFI error" print drop ;
-    dup third [ write ": " write ] when*
-    fourth print ;
 
 : heap-scan-error. ( obj -- )
     "Cannot do next-object outside begin/end-scan" print drop ;

basis/delegate/delegate-docs.factor

@@ -24,7 +24,7 @@ HELP: CONSULT:
 
 HELP: SLOT-PROTOCOL:
 { $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
-{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
+{ $description "Defines a protocol consisting of reader and writer words for the listed slot names." } ;
 
 { define-protocol POSTPONE: PROTOCOL: } related-words
 

basis/delegate/delegate-tests.factor

@@ -1,6 +1,6 @@
 USING: delegate kernel arrays tools.test words math definitions
 compiler.units parser generic prettyprint io.streams.string
-accessors eval multiline generic.standard delegate.protocols
+accessors eval multiline generic.single delegate.protocols
 delegate.private assocs see ;
 IN: delegate.tests
 

basis/dlists/dlists-docs.factor

@@ -15,6 +15,7 @@ $nl
 "Iterating over elements:"
 { $subsection dlist-each }
 { $subsection dlist-find }
+{ $subsection dlist-filter }
 { $subsection dlist-any? }
 "Deleting a node matching a predicate:"
 { $subsection delete-node-if* }
@@ -40,6 +41,11 @@ HELP: dlist-find
     "This operation is O(n)."
 } ;
 
+HELP: dlist-filter
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
+{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
+{ $side-effects { "dlist" } } ;
+
 HELP: dlist-any?
 { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
 { $description "Just like " { $link dlist-find } " except it doesn't return the object." }

basis/dlists/dlists-tests.factor

@@ -79,3 +79,8 @@ IN: dlists.tests
 [ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
 
 [ V{ } ] [ <dlist> dlist>seq ] unit-test
+
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test

basis/dlists/dlists.factor

@@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
     [
         [
             [ empty-dlist ] unless*
-            [ f ] change-next drop
+            next>>
             f over set-prev-when
         ] change-front drop
     ] keep
@@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
     [
         [
             [ empty-dlist ] unless*
-            [ f ] change-prev drop
+            prev>>
             f over set-next-when
         ] change-back drop
     ] keep
@@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
 
 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
 
+: dlist-filter ( dlist quot -- dlist )
+    over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
+
 M: dlist clone
     <dlist> [ '[ _ push-back ] dlist-each ] keep ;
 

basis/documents/elements/elements.factor

@@ -79,6 +79,13 @@ M: one-word-elt next-elt
     drop
     [ f next-word ] modify-col ;
 
+SINGLETON: word-start-elt
+
+M: word-start-elt prev-elt
+    drop one-word-elt prev-elt ;
+
+M: word-start-elt next-elt 2drop ;
+
 SINGLETON: word-elt
 
 M: word-elt prev-elt

basis/editors/editors.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer kernel namespaces sequences definitions io.files
+USING: parser lexer kernel namespaces sequences definitions
-io.backend io.pathnames io summary continuations tools.crossref
+io.files io.backend io.pathnames io summary continuations
-tools.vocabs prettyprint source-files source-files.errors assocs
+tools.crossref vocabs.hierarchy prettyprint source-files
-vocabs vocabs.loader splitting accessors debugger prettyprint
+source-files.errors assocs vocabs vocabs.loader splitting
-help.topics ;
+accessors debugger prettyprint help.topics ;
 IN: editors
 
 TUPLE: no-edit-hook ;

basis/formatting/formatting.factor

@@ -4,7 +4,7 @@
 USING: accessors arrays ascii assocs calendar combinators fry kernel 
 generalizations io io.encodings.ascii io.files io.streams.string
 macros math math.functions math.parser peg.ebnf quotations
-sequences splitting strings unicode.case vectors ;
+sequences splitting strings unicode.case vectors combinators.smart ;
 
 IN: formatting
 
@@ -113,7 +113,6 @@ MACRO: printf ( format-string -- )
 : sprintf ( format-string -- result )
     [ printf ] with-string-writer ; inline
 
-
 <PRIVATE
 
 : pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
@@ -129,12 +128,15 @@ MACRO: printf ( format-string -- )
     [ pad-00 ] map "/" join ; inline
 
 : >datetime ( timestamp -- string )
-    { [ day-of-week day-abbreviation3 ]
+    [
+       {
+          [ day-of-week day-abbreviation3 ]
           [ month>> month-abbreviation ]
           [ day>> pad-00 ]
           [ >time ]
           [ year>> number>string ]
-    } cleave 5 narray " " join ; inline
+       } cleave
+    ] output>array " " join ; inline
 
 : (week-of-year) ( timestamp day -- n )
     [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
@@ -187,5 +189,3 @@ PRIVATE>
 MACRO: strftime ( format-string -- )
     parse-strftime [ length ] keep [ ] join
     '[ _ <vector> @ reverse concat nip ] ;
-
-

basis/fry/fry-docs.factor

@@ -57,7 +57,6 @@ $nl
 "Here are some built-in combinators rewritten in terms of fried quotations:"
 { $table
     { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
-    { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }
     { { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
     { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
     { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }