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

Conflicts:

	extra/semantic-db/semantic-db.factor

.gitignore

@@ -2,6 +2,7 @@
 _darcs
 *.obj
 *.o
+*.s
 *.exe
 Factor/factor
 *.a

build-support/factor.sh

@@ -439,7 +439,7 @@ install_build_system_port() {
 }
 
 usage() {
-    echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap|make-target"
+    echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target"
     echo "If you are behind a firewall, invoke as:"
     echo "env GIT_PROTOCOL=http $0 <command>"
 }

core/alien/alien.factor

@@ -28,12 +28,6 @@ M: f expired? drop t ;
 : <alien> ( address -- alien )
     f <displaced-alien> { simple-c-ptr } declare ; inline
 
-: alien>native-string ( alien -- string )
-    os windows? [ alien>u16-string ] [ alien>char-string ] if ;
-
-: dll-path ( dll -- string )
-    (dll-path) alien>native-string ;
-
 M: alien equal?
     over alien? [
         2dup [ expired? ] either? [

core/alien/arrays/arrays-docs.factor

@@ -18,7 +18,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
 { $subsection >c-ushort-array    }
 { $subsection >c-void*-array     }
 { $subsection c-bool-array>      }
-{ $subsection c-char*-array>     }
 { $subsection c-char-array>      }
 { $subsection c-double-array>    }
 { $subsection c-float-array>     }
@@ -30,7 +29,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
 { $subsection c-uint-array>      }
 { $subsection c-ulong-array>     }
 { $subsection c-ulonglong-array> }
-{ $subsection c-ushort*-array>   }
 { $subsection c-ushort-array>    }
 { $subsection c-void*-array>     } ;
 
@@ -61,9 +59,7 @@ ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
 { $subsection double-nth }
 { $subsection set-double-nth }
 { $subsection void*-nth }
-{ $subsection set-void*-nth }
+{ $subsection set-void*-nth } ;
-{ $subsection char*-nth }
-{ $subsection ushort*-nth } ;
 
 ARTICLE: "c-arrays" "C arrays"
 "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."

core/alien/arrays/arrays.factor

@@ -1,8 +1,7 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays alien.c-types alien.structs
-sequences math kernel generator.registers
+sequences math kernel namespaces libc cpu.architecture ;
-namespaces libc ;
 IN: alien.arrays
 
 UNION: value-type array struct-type ;
@@ -27,7 +26,9 @@ M: array stack-size drop "void*" stack-size ;
 
 M: value-type c-type-reg-class drop int-regs ;
 
-M: value-type c-type-prep drop f ;
+M: value-type c-type-boxer-quot drop f ;
+
+M: value-type c-type-unboxer-quot drop f ;
 
 M: value-type c-type-getter
     drop [ swap <displaced-alien> ] ;

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

@@ -62,28 +62,6 @@ HELP: <c-object>
 
 { <c-object> malloc-object } related-words
 
-HELP: string>char-alien ( string -- array )
-{ $values { "string" string } { "array" byte-array } }
-{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
-{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ;
-
-{ string>char-alien alien>char-string malloc-char-string } related-words
-
-HELP: alien>char-string ( c-ptr -- string )
-{ $values { "c-ptr" c-ptr } { "string" string } }
-{ $description "Reads a null-terminated 8-bit C string from the specified address." } ;
-
-HELP: string>u16-alien ( string -- array )
-{ $values { "string" string } { "array" byte-array } }
-{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." }
-{ $errors "Throws an error if the string contains null characters." } ;
-
-{ string>u16-alien alien>u16-string malloc-u16-string } related-words
-
-HELP: alien>u16-string ( c-ptr -- string )
-{ $values { "c-ptr" c-ptr } { "string" string } }
-{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
-
 HELP: memory>byte-array
 { $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
 { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
@@ -111,18 +89,6 @@ HELP: malloc-byte-array
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
 { $errors "Throws an error if memory allocation fails." } ;
 
-HELP: malloc-char-string
-{ $values { "string" string } { "alien" c-ptr } }
-{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if memory allocation fails." } ;
-
-HELP: malloc-u16-string
-{ $values { "string" string } { "alien" c-ptr } }
-{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if memory allocation fails." } ;
-
 HELP: define-nth
 { $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
 { $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
@@ -202,8 +168,6 @@ $nl
 { $subsection *float }
 { $subsection *double }
 { $subsection *void* }
-{ $subsection *char* }
-{ $subsection *ushort* }
 "Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
 
 ARTICLE: "c-types-specs" "C type specifiers"
@@ -267,26 +231,6 @@ $nl
 "A wrapper for temporarily allocating a block of memory:"
 { $subsection with-malloc } ;
 
-ARTICLE: "c-strings" "C strings"
-"The C library interface defines two types of C strings:"
-{ $table
-    { "C type" "Notes" }
-    { { $snippet "char*" } "8-bit per character null-terminated ASCII" }
-    { { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" }
-}
-"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. 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."
-"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>char-alien }
-{ $subsection string>u16-alien }
-{ $subsection malloc-char-string }
-{ $subsection malloc-u16-string }
-"The first two allocate " { $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
-"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
-{ $subsection alien>char-string }
-{ $subsection alien>u16-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: "c-data" "Passing data between Factor and C"
 "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
 $nl

core/alien/c-types/c-types-tests.factor

@@ -1,30 +1,6 @@
 IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc ;
+sequences system libc alien.strings io.encodings.utf8 ;
-
-[ "\u0000ff" ]
-[ "\u0000ff" string>char-alien alien>char-string ]
-unit-test
-
-[ "hello world" ]
-[ "hello world" string>char-alien alien>char-string ]
-unit-test
-
-[ "hello\u00abcdworld" ]
-[ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
-unit-test
-
-[ t ] [ f expired? ] unit-test
-
-[ "hello world" ] [
-    "hello world" malloc-char-string
-    dup alien>char-string swap free
-] unit-test
-
-[ "hello world" ] [
-    "hello world" malloc-u16-string
-    dup alien>u16-string swap free
-] unit-test
 
 : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
 
@@ -67,7 +43,7 @@ TYPEDEF: int* MyIntArray
 
 TYPEDEF: uchar* MyLPBYTE
 
-[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test
+[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test
 
 [
     0 B{ 1 2 3 4 } <displaced-alien> <void*>

core/alien/c-types/c-types.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bit-arrays byte-arrays float-arrays arrays
-generator.registers assocs kernel kernel.private libc math
+assocs kernel kernel.private libc math
 namespaces parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
@@ -14,7 +14,7 @@ DEFER: *char
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
 TUPLE: c-type
-boxer prep unboxer
+boxer boxer-quot unboxer unboxer-quot
 getter setter
 reg-class size align stack-align? ;
 
@@ -149,23 +149,12 @@ M: float-array byte-length length "double" heap-size * ;
 : malloc-byte-array ( byte-array -- alien )
     dup length dup malloc [ -rot memcpy ] keep ;
 
-: malloc-char-string ( string -- alien )
-    string>char-alien malloc-byte-array ;
-
-: malloc-u16-string ( string -- alien )
-    string>u16-alien malloc-byte-array ;
-
 : memory>byte-array ( alien len -- byte-array )
     dup <byte-array> [ -rot memcpy ] keep ;
 
 : byte-array>memory ( byte-array base -- )
     swap dup length memcpy ;
 
-DEFER: >c-ushort-array
-
-: string>u16-memory ( string base -- )
-    >r >c-ushort-array r> byte-array>memory ;
-
 : (define-nth) ( word type quot -- )
     >r heap-size [ rot * ] swap prefix r> append define-inline ;
 
@@ -378,7 +367,7 @@ M: long-long-type box-return ( type -- )
         "box_float" >>boxer
         "to_float" >>unboxer
         single-float-regs >>reg-class
-        [ >float ] >>prep
+        [ >float ] >>unboxer-quot
     "float" define-primitive-type
 
     <c-type>
@@ -389,30 +378,8 @@ M: long-long-type box-return ( type -- )
         "box_double" >>boxer
         "to_double" >>unboxer
         double-float-regs >>reg-class
-        [ >float ] >>prep
+        [ >float ] >>unboxer-quot
     "double" define-primitive-type
 
-    <c-type>
-        [ alien-cell alien>char-string ] >>getter
-        [ set-alien-cell ] >>setter
-        bootstrap-cell >>size
-        bootstrap-cell >>align
-        "box_char_string" >>boxer
-        "alien_offset" >>unboxer
-        [ string>char-alien ] >>prep
-    "char*" define-primitive-type
-
-    "char*" "uchar*" typedef
-
-    <c-type>
-        [ alien-cell alien>u16-string ] >>getter
-        [ set-alien-cell ] >>setter
-        4 >>size
-        4 >>align
-        "box_u16_string" >>boxer
-        "alien_offset" >>unboxer
-        [ string>u16-alien ] >>prep
-    "ushort*" define-primitive-type
-
     os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
 ] with-compilation-unit

core/alien/compiler/compiler-tests.factor

@@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
 namespaces namespaces tools.test sequences inference words
 arrays parser quotations continuations inference.backend effects
 namespaces.private io io.streams.string memory system threads
-tools.test ;
+tools.test math ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test
@@ -280,6 +280,10 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
 
 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
 
+FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
+
+[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
+
 ! Test callbacks
 
 : callback-1 "void" { } "cdecl" [ ] alien-callback ;
@@ -354,3 +358,18 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
     ] alien-callback ;
 
 [ ] [ callback-8 callback_test_1 ] unit-test
+
+: callback-9
+    "int" { "int" "int" "int" } "cdecl" [
+        + + 1+
+    ] alien-callback ;
+
+FUNCTION: void ffi_test_36_point_5 ( ) ;
+
+[ ] [ ffi_test_36_point_5 ] unit-test
+
+FUNCTION: int ffi_test_37 ( void* func ) ;
+
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test

core/alien/compiler/compiler.factor

@@ -3,10 +3,11 @@
 USING: arrays generator generator.registers generator.fixup
 hashtables kernel math namespaces sequences words
 inference.state inference.backend inference.dataflow system
-math.parser classes alien.arrays alien.c-types alien.structs
+math.parser classes alien.arrays alien.c-types alien.strings
-alien.syntax cpu.architecture alien inspector quotations assocs
+alien.structs alien.syntax cpu.architecture alien inspector
-kernel.private threads continuations.private libc combinators
+quotations assocs kernel.private threads continuations.private
-compiler.errors continuations layouts accessors ;
+libc combinators compiler.errors continuations layouts accessors
+;
 IN: alien.compiler
 
 TUPLE: #alien-node < node return parameters abi ;
@@ -20,9 +21,7 @@ TUPLE: #alien-invoke < #alien-node library function ;
 : large-struct? ( ctype -- ? )
     dup c-struct? [
         heap-size struct-small-enough? not
-    ] [
+    ] [ drop f ] if ;
-        drop f
-    ] if ;
 
 : alien-node-parameters* ( node -- seq )
     dup parameters>>
@@ -162,17 +161,16 @@ M: long-long-type flatten-value-type ( type -- )
     dup return>> "void" = 0 1 ?
     swap produce-values ;
 
-: (make-prep-quot) ( parameters -- )
+: (param-prep-quot) ( parameters -- )
     dup empty? [
         drop
     ] [
-        unclip c-type c-type-prep %
+        unclip c-type c-type-unboxer-quot %
-        \ >r , (make-prep-quot) \ r> ,
+        \ >r , (param-prep-quot) \ r> ,
     ] if ;
 
-: make-prep-quot ( node -- quot )
+: param-prep-quot ( node -- quot )
-    parameters>>
+    parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
-    [ <reversed> (make-prep-quot) ] [ ] make ;
 
 : unbox-parameters ( offset node -- )
     parameters>> [
@@ -200,6 +198,20 @@ M: long-long-type flatten-value-type ( type -- )
 : box-return* ( node -- )
     return>> [ ] [ box-return ] if-void ;
 
+: (return-prep-quot) ( parameters -- )
+    dup empty? [
+        drop
+    ] [
+        unclip c-type c-type-boxer-quot %
+        \ >r , (return-prep-quot) \ r> ,
+    ] if ;
+
+: callback-prep-quot ( node -- quot )
+    parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
+
+: return-prep-quot ( node -- quot )
+    [ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
+
 M: alien-invoke-error summary
     drop
     "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
@@ -258,15 +270,15 @@ M: no-such-symbol compiler-error-type
     pop-literal nip >>library
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup make-prep-quot recursive-state get infer-quot
+    dup param-prep-quot f infer-quot
     ! Set ABI
-    dup library>>
+    dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
-    library [ abi>> ] [ "cdecl" ] if*
-    >>abi
     ! Add node to IR
     dup node,
     ! Magic #: consume exactly the number of inputs
-    0 alien-invoke-stack
+    dup 0 alien-invoke-stack
+    ! Quotation which coerces return value to required type
+    return-prep-quot f infer-quot
 ] "infer" set-word-prop
 
 M: #alien-invoke generate-node
@@ -294,11 +306,13 @@ M: alien-indirect-error summary
     pop-parameters >>parameters
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup make-prep-quot [ dip ] curry recursive-state get infer-quot
+    dup param-prep-quot [ dip ] curry f infer-quot
     ! Add node to IR
     dup node,
     ! Magic #: consume the function pointer, too
-    1 alien-invoke-stack
+    dup 1 alien-invoke-stack
+    ! Quotation which coerces return value to required type
+    return-prep-quot f infer-quot
 ] "infer" set-word-prop
 
 M: #alien-indirect generate-node
@@ -331,7 +345,7 @@ M: alien-callback-error summary
 
 : callback-bottom ( node -- )
     xt>> [ word-xt drop <alien> ] curry
-    recursive-state get infer-quot ;
+    f infer-quot ;
 
 \ alien-callback [
     4 ensure-values
@@ -371,16 +385,18 @@ TUPLE: callback-context ;
     slip
     wait-to-return ; inline
 
-: prepare-callback-return ( ctype -- quot )
+: callback-return-quot ( ctype -- quot )
     return>> {
         { [ dup "void" = ] [ drop [ ] ] }
         { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
-        [ c-type c-type-prep ]
+        [ c-type c-type-unboxer-quot ]
     } cond ;
 
 : wrap-callback-quot ( node -- quot )
     [
-        [ quot>> ] [ prepare-callback-return ] bi append ,
+        [ callback-prep-quot ]
+        [ quot>> ]
+        [ callback-return-quot ] tri 3append ,
         [ callback-context new do-callback ] %
     ] [ ] make ;
 
@@ -403,12 +419,12 @@ TUPLE: callback-context ;
 : generate-callback ( node -- )
     dup xt>> dup [
         init-templates
-        %save-word-xt
         %prologue-later
         dup alien-stack-frame [
-            dup registers>objects
+            [ registers>objects ]
-            dup wrap-callback-quot %alien-callback
+            [ wrap-callback-quot %alien-callback ]
-            %callback-return
+            [ %callback-return ]
+            tri
         ] with-stack-frame
     ] with-generator ;
 

core/alien/remote-control/remote-control.factor

@@ -1,12 +1,12 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types parser threads words kernel.private
+USING: alien alien.c-types alien.strings parser threads words
-kernel ;
+kernel.private kernel io.encodings.utf8 ;
 IN: alien.remote-control
 
 : eval-callback
     "void*" { "char*" } "cdecl"
-    [ eval>string malloc-char-string ] alien-callback ;
+    [ eval>string utf8 malloc-string ] alien-callback ;
 
 : yield-callback
     "void" { } "cdecl" [ yield ] alien-callback ;

core/alien/strings/strings-docs.factor

@@ -0,0 +1,52 @@
+USING: help.markup help.syntax strings byte-arrays alien libc
+debugger ;
+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." } ;
+
+HELP: utf16n
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
+{ $see-also "encodings-introduction" } ;
+
+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. 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
+"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"

core/alien/strings/strings-tests.factor

@@ -0,0 +1,30 @@
+USING: alien.strings tools.test kernel libc
+io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
+io.encodings.ascii alien ;
+IN: alien.strings.tests
+
+[ "\u0000ff" ]
+[ "\u0000ff" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello world" ]
+[ "hello world" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello\u00abcdworld" ]
+[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
+unit-test
+
+[ t ] [ f expired? ] unit-test
+
+[ "hello world" ] [
+    "hello world" ascii malloc-string
+    dup ascii alien>string swap free
+] unit-test
+
+[ "hello world" ] [
+    "hello world" utf16n malloc-string
+    dup utf16n alien>string swap free
+] unit-test
+
+[ f ] [ f utf8 alien>string ] unit-test

core/alien/strings/strings.factor

@@ -0,0 +1,111 @@
+! 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.streams.byte-array io.streams.memory io.encodings.utf8
+io.encodings.utf16 system alien strings cpu.architecture ;
+IN: alien.strings
+
+GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
+
+M: c-ptr alien>string
+    >r <memory-stream> r> <decoder>
+    "\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 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 ] curry [ ] like ;
+
+M: string-type c-type-unboxer-quot
+    second [ string>alien ] curry [ ] like ;
+
+M: string-type c-type-getter
+    drop [ alien-cell ] ;
+
+M: string-type c-type-setter
+    drop [ set-alien-cell ] ;
+
+TUPLE: utf16n ;
+
+! Native-order UTF-16
+
+: utf16n ( -- descriptor )
+    little-endian? utf16le utf16be ? ; foldable
+
+M: utf16n <decoder> drop utf16n <decoder> ;
+
+M: utf16n <encoder> drop utf16n <encoder> ;
+
+: alien>native-string ( alien -- string )
+    os windows? [ utf16n ] [ utf8 ] if alien>string ;
+
+: dll-path ( dll -- string )
+    (dll-path) alien>native-string ;
+
+: string>symbol ( str -- alien )
+    [ os wince? [ utf16n ] [ utf8 ] if string>alien ]
+    over string? [ call ] [ map ] if ;
+
+{ "char*" utf8 } "char*" typedef
+{ "char*" utf16n } "wchar_t*" typedef
+"char*" "uchar*" typedef

core/alien/structs/structs-tests.factor

@@ -1,6 +1,6 @@
 IN: alien.structs.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc words vocabs namespaces ;
+sequences system libc words vocabs namespaces layouts ;
 
 C-STRUCT: bar
     { "int" "x" }
@@ -9,20 +9,20 @@ C-STRUCT: bar
 [ 36 ] [ "bar" heap-size ] unit-test
 [ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
 
-! This was actually only correct on Windows/x86:
+C-STRUCT: align-test
+    { "int" "x" }
+    { "double" "y" } ;
 
-! C-STRUCT: align-test
+os winnt? cpu x86? and [
-!     { "int" "x" }
+    [ 16 ] [ "align-test" heap-size ] unit-test
-!     { "double" "y" } ;
+    
-! 
+    cell 4 = [
-! [ 16 ] [ "align-test" heap-size ] unit-test
+        C-STRUCT: one
-! 
+        { "long" "a" } { "double" "b" } { "int" "c" } ;
-! cell 4 = [
+    
-!     C-STRUCT: one
+        [ 24 ] [ "one" heap-size ] unit-test
-!     { "long" "a" } { "double" "b" } { "int" "c" } ;
+    ] when
-! 
+] when
-!     [ 24 ] [ "one" heap-size ] unit-test
-! ] when
 
 : MAX_FOOS 30 ;
 

core/alien/structs/structs.factor

@@ -20,14 +20,19 @@ IN: alien.structs
 
 : define-getter ( type spec -- )
     [ set-reader-props ] keep
-    dup slot-spec-reader
+    [ ]
-    over slot-spec-type c-getter
+    [ slot-spec-reader ]
+    [
+        slot-spec-type
+        [ c-getter ] [ c-type c-type-boxer-quot ] bi append
+    ] tri
     define-struct-slot-word ;
 
 : define-setter ( type spec -- )
     [ set-writer-props ] keep
-    dup slot-spec-writer
+    [ ]
-    over slot-spec-type c-setter
+    [ slot-spec-writer ]
+    [ slot-spec-type c-setter ] tri
     define-struct-slot-word ;
 
 : define-field ( type spec -- )

core/alien/syntax/syntax.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays alien alien.c-types alien.structs alien.arrays
-kernel math namespaces parser sequences words quotations
+alien.strings kernel math namespaces parser sequences words
-math.parser splitting effects prettyprint prettyprint.sections
+quotations math.parser splitting effects prettyprint
-prettyprint.backend assocs combinators ;
+prettyprint.sections prettyprint.backend assocs combinators ;
 IN: alien.syntax
 
 <PRIVATE

core/bootstrap/primitives.factor

@@ -58,16 +58,13 @@ num-types get f <array> builtins set
     "alien.accessors"
     "arrays"
     "bit-arrays"
-    "bit-vectors"
     "byte-arrays"
-    "byte-vectors"
     "classes.private"
     "classes.tuple"
     "classes.tuple.private"
     "compiler.units"
     "continuations.private"
     "float-arrays"
-    "float-vectors"
     "generator"
     "growable"
     "hashtables"
@@ -455,54 +452,6 @@ tuple
     }
 } define-tuple-class
 
-"byte-vector" "byte-vectors" create
-tuple
-{
-    {
-        { "byte-array" "byte-arrays" }
-        "underlying"
-        { "underlying" "growable" }
-        { "set-underlying" "growable" }
-    } {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    }
-} define-tuple-class
-
-"bit-vector" "bit-vectors" create
-tuple
-{
-    {
-        { "bit-array" "bit-arrays" }
-        "underlying"
-        { "underlying" "growable" }
-        { "set-underlying" "growable" }
-    } {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    }
-} define-tuple-class
-
-"float-vector" "float-vectors" create
-tuple
-{
-    {
-        { "float-array" "float-arrays" }
-        "underlying"
-        { "underlying" "growable" }
-        { "set-underlying" "growable" }
-    } {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    }
-} define-tuple-class
-
 "curry" "kernel" create
 tuple
 {
@@ -689,10 +638,6 @@ tuple
     { "set-alien-double" "alien.accessors" }
     { "alien-cell" "alien.accessors" }
     { "set-alien-cell" "alien.accessors" }
-    { "alien>char-string" "alien" }
-    { "string>char-alien" "alien" }
-    { "alien>u16-string" "alien" }
-    { "string>u16-alien" "alien" }
     { "(throw)" "kernel.private" }
     { "alien-address" "alien" }
     { "slot" "slots.private" }

core/bootstrap/stage2.factor

@@ -27,10 +27,6 @@ SYMBOL: bootstrap-time
     diff
     [ "bootstrap." prepend require ] each ;
 
-! : compile-remaining ( -- )
-!     "Compiling remaining words..." print flush
-!     vocabs [ words [ compiled? not ] subset compile ] each ;
-
 : count-words ( pred -- )
     all-words swap subset length number>string write ;
 

core/bootstrap/syntax.factor

@@ -14,16 +14,13 @@ IN: bootstrap.syntax
     ";"
     "<PRIVATE"
     "?{"
-    "?V{"
     "BIN:"
     "B{"
-    "BV{"
     "C:"
     "CHAR:"
     "DEFER:"
     "ERROR:"
     "F{"
-    "FV{"
     "FORGET:"
     "GENERIC#"
     "GENERIC:"

core/classes/algebra/algebra-tests.factor

@@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
-random inference effects kernel.private ;
+random inference effects kernel.private sbufs ;
 
 : class= [ class< ] 2keep swap class< and ;
 
@@ -144,6 +144,48 @@ UNION: z1 b1 c1 ;
 
 [ f ] [ null class-not null class= ] unit-test
 
+[ t ] [
+    fixnum class-not
+    fixnum fixnum class-not class-or
+    class<
+] unit-test
+
+! Test method inlining
+[ f ] [ fixnum { } min-class ] unit-test
+
+[ string ] [
+    \ string
+    [ integer string array reversed sbuf
+    slice vector quotation ]
+    sort-classes min-class
+] unit-test
+
+[ fixnum ] [
+    \ fixnum
+    [ fixnum integer object ]
+    sort-classes min-class
+] unit-test
+
+[ integer ] [
+    \ fixnum
+    [ integer float object ]
+    sort-classes min-class
+] unit-test
+
+[ object ] [
+    \ word
+    [ integer float object ]
+    sort-classes min-class
+] unit-test
+
+[ reversed ] [
+    \ reversed
+    [ integer reversed slice ]
+    sort-classes min-class
+] unit-test
+
+[ f ] [ null { number fixnum null } min-class ] unit-test
+
 ! Test for hangs?
 : random-class classes random ;
 

core/classes/algebra/algebra.factor

@@ -77,10 +77,10 @@ C: <anonymous-complement> anonymous-complement
         { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
         { [ over anonymous-union? ] [ left-anonymous-union< ] }
         { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
-        { [ over anonymous-complement? ] [ 2drop f ] }
         { [ over members ] [ left-union-class< ] }
         { [ dup anonymous-union? ] [ right-anonymous-union< ] }
         { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
+        { [ over anonymous-complement? ] [ 2drop f ] }
         { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
         { [ dup members ] [ right-union-class< ] }
         { [ over superclass ] [ superclass< ] }
@@ -193,9 +193,8 @@ C: <anonymous-complement> anonymous-complement
     [ ] unfold nip ;
 
 : min-class ( class seq -- class/f )
-    [ dupd classes-intersect? ] subset dup empty? [
+    over [ classes-intersect? ] curry subset
-        2drop f
+    dup empty? [ 2drop f ] [
-    ] [
         tuck [ class< ] with all? [ peek ] [ drop f ] if
     ] if ;
 

core/classes/tuple/tuple-tests.factor

@@ -3,7 +3,8 @@ math.constants parser sequences tools.test words assocs
 namespaces quotations sequences.private classes continuations
 generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
-calendar prettyprint io.streams.string splitting inspector ;
+calendar prettyprint io.streams.string splitting inspector
+columns ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;

core/combinators/combinators.factor

@@ -150,7 +150,7 @@ M: hashtable hashcode*
         drop
     ] [
         dup length 4 <=
-        over keys [ word? ] contains? or
+        over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
         [
             linear-case-quot
         ] [

core/compiler/tests/intrinsics.factor

@@ -4,8 +4,8 @@ math.constants math.private sequences strings tools.test words
 continuations sequences.private hashtables.private byte-arrays
 strings.private system random layouts vectors.private
 sbufs.private strings.private slots.private alien
-alien.accessors alien.c-types alien.syntax namespaces libc
+alien.accessors alien.c-types alien.syntax alien.strings
-sequences.private ;
+namespaces libc sequences.private io.encodings.ascii ;
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-call ] unit-test
@@ -361,11 +361,11 @@ cell 8 = [
     [ ] [ "b" get free ] unit-test
 ] when
 
-[ ] [ "hello world" malloc-char-string "s" set ] unit-test
+[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
 
 "s" get [
-    [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
+    [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
-    [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
+    [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
 
     [ ] [ "s" get free ] unit-test
 ] when

core/compiler/tests/simple.factor

@@ -1,6 +1,6 @@
 USING: compiler.units tools.test kernel kernel.private
 sequences.private math.private math combinators strings
-alien arrays memory ;
+alien arrays memory vocabs parser ;
 IN: compiler.tests
 
 ! Test empty word
@@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ;
 
 ! Regression
 [ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
+
+! Regression
+10 [
+    [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
+    [ t ] [
+        "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) (  -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
+    ] unit-test
+] times

core/compiler/tests/templates-early.factor

@@ -2,7 +2,8 @@
 IN: compiler.tests
 USING: compiler generator generator.registers
 generator.registers.private tools.test namespaces sequences
-words kernel math effects definitions compiler.units accessors ;
+words kernel math effects definitions compiler.units accessors
+cpu.architecture ;
 
 : <int-vreg> ( n -- vreg ) int-regs <vreg> ;
 

core/compiler/tests/templates.factor

@@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
 hashtables.private math.private namespaces sequences
 sequences.private tools.test namespaces.private slots.private
 sequences.private byte-arrays alien alien.accessors layouts
-words definitions compiler.units io combinators ;
+words definitions compiler.units io combinators vectors ;
 IN: compiler.tests
 
 ! Oops!
@@ -246,3 +246,12 @@ TUPLE: my-tuple ;
     } cleave ;
 
 [ t ] [ \ float-spill-bug compiled? ] unit-test
+
+! Regression
+: dispatch-alignment-regression ( -- c )
+    { tuple vector } 3 slot { word } declare
+    dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
+
+[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
+
+[ vector ] [ dispatch-alignment-regression ] unit-test

core/cpu/architecture/architecture.factor

@@ -1,10 +1,17 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic kernel kernel.private math memory
 namespaces sequences layouts system hashtables classes alien
 byte-arrays bit-arrays float-arrays combinators words sets ;
 IN: cpu.architecture
 
+! Register classes
+SINGLETON: int-regs
+SINGLETON: single-float-regs
+SINGLETON: double-float-regs
+UNION: float-regs single-float-regs double-float-regs ;
+UNION: reg-class int-regs float-regs ;
+
 ! A pseudo-register class for parameters spilled on the stack
 SINGLETON: stack-params
 
@@ -56,7 +63,7 @@ HOOK: %call cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 
 ! Test if vreg is 'f' or not
-HOOK: %jump-t cpu ( label -- )
+HOOK: %jump-f cpu ( label -- )
 
 HOOK: %dispatch cpu ( -- )
 
@@ -187,6 +194,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 
 HOOK: %box-alien cpu ( dst src -- )
 
+! GC check
+HOOK: %gc cpu
+
 : operand ( var -- op ) get v>operand ; inline
 
 : unique-operands ( operands quot -- )

core/cpu/ppc/allot/allot.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel cpu.ppc.architecture cpu.ppc.assembler
 kernel.private namespaces math sequences generic arrays
@@ -7,7 +7,7 @@ cpu.architecture alien ;
 IN: cpu.ppc.allot
 
 : load-zone-ptr ( reg -- )
-    "nursery" f pick %load-dlsym dup 0 LWZ ;
+    >r "nursery" f r> %load-dlsym ;
 
 : %allot ( header size -- )
     #! Store a pointer to 'size' bytes allocated from the
@@ -25,6 +25,19 @@ IN: cpu.ppc.allot
 : %store-tagged ( reg tag -- )
     >r dup fresh-object v>operand 11 r> tag-number ORI ;
 
+M: ppc %gc
+    "end" define-label
+    12 load-zone-ptr
+    11 12 cell LWZ ! nursery.here -> r11
+    12 12 3 cells LWZ ! nursery.end -> r12
+    11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
+    11 0 12 CMP ! is here >= end?
+    "end" get BLE
+    0 frame-required
+    %prepare-alien-invoke
+    "minor_gc" f %alien-invoke
+    "end" resolve-label ;
+
 : %allot-float ( reg -- )
     #! exits with tagged ptr to object in r12, untagged in r11
     float 16 %allot

core/cpu/ppc/architecture/architecture.factor

@@ -106,8 +106,8 @@ M: ppc %call ( label -- ) BL ;
 
 M: ppc %jump-label ( label -- ) B ;
 
-M: ppc %jump-t ( label -- )
+M: ppc %jump-f ( label -- )
-    0 "flag" operand f v>operand CMPI BNE ;
+    0 "flag" operand f v>operand CMPI BEQ ;
 
 M: ppc %dispatch ( -- )
     [

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -217,11 +217,11 @@ IN: cpu.ppc.intrinsics
     2array define-if-intrinsics ;
 
 {
-    { fixnum< BLT }
+    { fixnum< BGE }
-    { fixnum<= BLE }
+    { fixnum<= BGT }
-    { fixnum> BGT }
+    { fixnum> BLE }
-    { fixnum>= BGE }
+    { fixnum>= BLT }
-    { eq? BEQ }
+    { eq? BNE }
 } [
     first2 define-fixnum-jump
 ] each
@@ -356,11 +356,11 @@ IN: cpu.ppc.intrinsics
     { { float "x" } { float "y" } } define-if-intrinsic ;
 
 {
-    { float< BLT }
+    { float< BGE }
-    { float<= BLE }
+    { float<= BGT }
-    { float> BGT }
+    { float> BLE }
-    { float>= BGE }
+    { float>= BLT }
-    { float= BEQ }
+    { float= BNE }
 } [
     first2 define-float-jump
 ] each

core/cpu/x86/32/32.factor

@@ -16,8 +16,9 @@ IN: cpu.x86.32
 M: x86.32 ds-reg ESI ;
 M: x86.32 rs-reg EDI ;
 M: x86.32 stack-reg ESP ;
-M: x86.32 xt-reg ECX ;
 M: x86.32 stack-save-reg EDX ;
+M: x86.32 temp-reg-1 EAX ;
+M: x86.32 temp-reg-2 ECX ;
 
 M: temp-reg v>operand drop EBX ;
 
@@ -267,7 +268,7 @@ os windows? [
     EDX 26 SHR
     EDX 1 AND
     { EAX EBX ECX EDX } [ POP ] each
-    JNE
+    JE
 ] { } define-if-intrinsic
 
 "-no-sse2" cli-args member? [

core/cpu/x86/64/64.factor

@@ -11,8 +11,9 @@ IN: cpu.x86.64
 M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
-M: x86.64 xt-reg RCX ;
 M: x86.64 stack-save-reg RSI ;
+M: x86.64 temp-reg-1 RAX ;
+M: x86.64 temp-reg-2 RCX ;
 
 M: temp-reg v>operand drop RBX ;
 

core/cpu/x86/allot/allot.factor

@@ -16,12 +16,12 @@ IN: cpu.x86.allot
 
 : object@ ( n -- operand ) cells (object@) ;
 
-: load-zone-ptr ( -- )
+: load-zone-ptr ( reg -- )
     #! Load pointer to start of zone array
-    "nursery" f allot-reg %alien-global ;
+    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
 
 : load-allot-ptr ( -- )
-    load-zone-ptr
+    allot-reg load-zone-ptr
     allot-reg PUSH
     allot-reg dup cell [+] MOV ;
 
@@ -29,6 +29,19 @@ IN: cpu.x86.allot
     allot-reg POP
     allot-reg cell [+] swap 8 align ADD ;
 
+M: x86 %gc ( -- )
+    "end" define-label
+    temp-reg-1 load-zone-ptr
+    temp-reg-2 temp-reg-1 cell [+] MOV
+    temp-reg-2 1024 ADD
+    temp-reg-1 temp-reg-1 3 cells [+] MOV
+    temp-reg-2 temp-reg-1 CMP
+    "end" get JLE
+    0 frame-required
+    %prepare-alien-invoke
+    "minor_gc" f %alien-invoke
+    "end" resolve-label ;
+
 : store-header ( header -- )
     0 object@ swap type-number tag-fixnum MOV ;
 

core/cpu/x86/architecture/architecture.factor

@@ -9,7 +9,6 @@ IN: cpu.x86.architecture
 HOOK: ds-reg cpu
 HOOK: rs-reg cpu
 HOOK: stack-reg cpu
-HOOK: xt-reg cpu
 HOOK: stack-save-reg cpu
 
 : stack@ stack-reg swap [+] ;
@@ -35,6 +34,10 @@ GENERIC: push-return-reg ( reg-class -- )
 GENERIC: load-return-reg ( stack@ reg-class -- )
 GENERIC: store-return-reg ( stack@ reg-class -- )
 
+! Only used by inline allocation
+HOOK: temp-reg-1 cpu
+HOOK: temp-reg-2 cpu
+
 HOOK: address-operand cpu ( address -- operand )
 
 HOOK: fixnum>slot@ cpu
@@ -47,13 +50,13 @@ M: x86 stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
 M: x86 %save-word-xt ( -- )
-    xt-reg 0 MOV rc-absolute-cell rel-this ;
+    temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
 
 : factor-area-size 4 cells ;
 
 M: x86 %prologue ( n -- )
     dup cell + PUSH
-    xt-reg PUSH
+    temp-reg v>operand PUSH
     stack-reg swap 2 cells - SUB ;
 
 M: x86 %epilogue ( n -- )
@@ -76,8 +79,8 @@ M: x86 %call ( label -- ) CALL ;
 
 M: x86 %jump-label ( label -- ) JMP ;
 
-M: x86 %jump-t ( label -- )
+M: x86 %jump-f ( label -- )
-    "flag" operand f v>operand CMP JNE ;
+    "flag" operand f v>operand CMP JE ;
 
 : code-alignment ( -- n )
     building get length dup cell align swap - ;

core/cpu/x86/intrinsics/intrinsics.factor

@@ -212,11 +212,11 @@ IN: cpu.x86.intrinsics
     2array define-if-intrinsics ;
 
 {
-    { fixnum< JL }
+    { fixnum< JGE }
-    { fixnum<= JLE }
+    { fixnum<= JG }
-    { fixnum> JG }
+    { fixnum> JLE }
-    { fixnum>= JGE }
+    { fixnum>= JL }
-    { eq? JE }
+    { eq? JNE }
 } [
     first2 define-fixnum-jump
 ] each

core/cpu/x86/sse2/sse2.factor

@@ -27,11 +27,11 @@ IN: cpu.x86.sse2
     { { float "x" } { float "y" } } define-if-intrinsic ;
 
 {
-    { float< JB }
+    { float< JAE }
-    { float<= JBE }
+    { float<= JA }
-    { float> JA }
+    { float> JBE }
-    { float>= JAE }
+    { float>= JB }
-    { float= JE }
+    { float= JNE }
 } [
     first2 define-float-jump
 ] each

core/generator/fixup/fixup-docs.factor

@@ -13,12 +13,6 @@ HELP: add-literal
 { $values { "obj" object } { "n" integer } }
 { $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
 
-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." } ;
-
 HELP: rel-dlsym
 { $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
 { $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."

core/generator/fixup/fixup.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs hashtables
 kernel kernel.private math namespaces sequences words
-quotations strings alien layouts system combinators
+quotations strings alien.strings layouts system combinators
 math.bitfields words.private cpu.architecture ;
 IN: generator.fixup
 
@@ -110,10 +110,6 @@ SYMBOL: literal-table
 
 : add-literal ( obj -- n ) literal-table get push-new* ;
 
-: string>symbol ( str -- alien )
-    [ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
-    over string? [ call ] [ map ] if ;
-
 : add-dlsym-literals ( symbol dll -- )
     >r string>symbol r> 2array literal-table get push-all ;
 

core/generator/generator.factor

@@ -40,16 +40,16 @@ SYMBOL: current-label-start
     compiled-stack-traces?
     compiling-word get f ?
     1vector literal-table set
-    f compiling-word get compiled get set-at ;
+    f compiling-label get compiled get set-at ;
 
-: finish-compiling ( literals relocation labels code -- )
+: save-machine-code ( literals relocation labels code -- )
     4array compiling-label get compiled get set-at ;
 
 : with-generator ( node word label quot -- )
     [
         >r begin-compiling r>
         { } make fixup
-        finish-compiling
+        save-machine-code
     ] with-scope ; inline
 
 GENERIC: generate-node ( node -- next )
@@ -73,6 +73,7 @@ GENERIC: generate-node ( node -- next )
 : word-dataflow ( word -- effect dataflow )
     [
         dup "no-effect" word-prop [ no-effect ] when
+        dup "no-compile" word-prop [ no-effect ] when
         dup specialized-def over dup 2array 1array infer-quot
         finish-word
     ] with-infer ;
@@ -131,14 +132,14 @@ M: #loop generate-node
 
 : generate-if ( node label -- next )
     <label> [
-        >r >r node-children first2 generate-branch
+        >r >r node-children first2 swap generate-branch
         r> r> end-false-branch resolve-label
         generate-branch
         init-templates
     ] keep resolve-label iterate-next ;
 
 M: #if generate-node
-    [ <label> dup %jump-t ]
+    [ <label> dup %jump-f ]
     H{ { +input+ { { f "flag" } } } }
     with-template
     generate-if ;
@@ -189,13 +190,13 @@ M: #dispatch generate-node
     "if-intrinsics" set-word-prop ;
 
 : if>boolean-intrinsic ( quot -- )
-    "true" define-label
+    "false" define-label
     "end" define-label
-    "true" get swap call
+    "false" get swap call
-    f "if-scratch" get load-literal
-    "end" get %jump-label
-    "true" resolve-label
     t "if-scratch" get load-literal
+    "end" get %jump-label
+    "false" resolve-label
+    f "if-scratch" get load-literal
     "end" resolve-label
     "if-scratch" get phantom-push ; inline
 

core/generator/registers/registers.factor

@@ -13,13 +13,6 @@ SYMBOL: +scratch+
 SYMBOL: +clobber+
 SYMBOL: known-tag
 
-! Register classes
-SINGLETON: int-regs
-SINGLETON: single-float-regs
-SINGLETON: double-float-regs
-UNION: float-regs single-float-regs double-float-regs ;
-UNION: reg-class int-regs float-regs ;
-
 <PRIVATE
 
 ! Value protocol
@@ -65,9 +58,7 @@ M: float-regs move-spec drop float ;
 M: float-regs operand-class* drop float ;
 
 ! Temporary register for stack shuffling
-TUPLE: temp-reg reg-class>> ;
+SINGLETON: temp-reg
-
-: temp-reg T{ temp-reg f int-regs } ;
 
 M: temp-reg move-spec drop f ;
 
@@ -470,11 +461,6 @@ M: loc lazy-store
 : finalize-contents ( -- )
     finalize-locs finalize-vregs reset-phantoms ;
 
-: %gc ( -- )
-    0 frame-required
-    %prepare-alien-invoke
-    "simple_gc" f %alien-invoke ;
-
 ! Loading stacks to vregs
 : free-vregs? ( int# float# -- ? )
     double-float-regs free-vregs length <=

core/generic/generic.factor

@@ -29,6 +29,9 @@ PREDICATE: method-spec < pair
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
+: specific-method ( class word -- class )
+    order min-class ;
+
 GENERIC: effective-method ( ... generic -- method )
 
 : next-method-class ( class generic -- class/f )

core/generic/standard/engines/tuple/tuple.factor

@@ -1,8 +1,11 @@
-IN: generic.standard.engines.tuple
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes.tuple.private hashtables assocs sorting
 accessors combinators sequences slots.private math.parser words
 effects namespaces generic generic.standard.engines
-classes.algebra math math.private quotations arrays ;
+classes.algebra math math.private kernel.private
+quotations arrays ;
+IN: generic.standard.engines.tuple
 
 TUPLE: echelon-dispatch-engine n methods ;
 
@@ -27,14 +30,7 @@ TUPLE: tuple-dispatch-engine echelons ;
 
 : <tuple-dispatch-engine> ( methods -- engine )
     echelon-sort
-    [
+    [ dupd <echelon-dispatch-engine> ] assoc-map
-        over zero? [
-            dup assoc-empty?
-            [ drop f ] [ values first ] if
-        ] [
-            dupd <echelon-dispatch-engine>
-        ] if
-    ] assoc-map [ nip ] assoc-subset
     \ tuple-dispatch-engine boa ;
 
 : convert-tuple-methods ( assoc -- assoc' )
@@ -48,52 +44,51 @@ M: trivial-tuple-dispatch-engine engine>quot
     >alist V{ } clone [ hashcode 1array ] distribute-buckets
     [ <trivial-tuple-dispatch-engine> ] map ;
 
+: word-hashcode% [ 1 slot ] % ;
+
 : class-hash-dispatch-quot ( methods -- quot )
-    #! 1 slot == word hashcode
     [
-        [ dup 1 slot ] %
+        \ dup ,
+        word-hashcode%
         hash-methods [ engine>quot ] map hash-dispatch-quot %
     ] [ ] make ;
 
-: tuple-dispatch-engine-word-name ( engine -- string )
+: engine-word-name ( -- string )
-    [
+    generic get word-name "/tuple-dispatch-engine" append ;
-        generic get word-name %
-        "/tuple-dispatch-engine/" %
-        n>> #
-    ] "" make ;
 
-PREDICATE: tuple-dispatch-engine-word < word
+PREDICATE: engine-word < word
     "tuple-dispatch-generic" word-prop generic? ;
 
-M: tuple-dispatch-engine-word stack-effect
+M: engine-word stack-effect
     "tuple-dispatch-generic" word-prop
     [ extra-values ] [ stack-effect ] bi
     dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
 
-M: tuple-dispatch-engine-word compiled-crossref?
+M: engine-word compiled-crossref?
     drop t ;
 
 : remember-engine ( word -- )
     generic get "engines" word-prop push ;
 
-: <tuple-dispatch-engine-word> ( engine -- word )
+: <engine-word> ( -- word )
-    tuple-dispatch-engine-word-name f <word>
+    engine-word-name f <word>
-    [ generic get "tuple-dispatch-generic" set-word-prop ]
+    dup generic get "tuple-dispatch-generic" set-word-prop ;
-    [ remember-engine ]
-    [ ]
-    tri ;
 
-: define-tuple-dispatch-engine-word ( engine quot -- word )
+: define-engine-word ( quot -- word )
-    >r <tuple-dispatch-engine-word> dup r> define ;
+    >r <engine-word> dup r> define ;
+
+: array-nth% 2 + , [ slot { word } declare ] % ;
+
+: tuple-layout-superclasses ( obj -- array )
+    { tuple } declare
+    1 slot { tuple-layout } declare
+    4 slot { array } declare ; inline
 
 : tuple-dispatch-engine-body ( engine -- quot )
-    #! 1 slot == tuple-layout
-    #! 2 slot == 0 array-nth
-    #! 4 slot == layout-superclasses
     [
         picker %
-        [ 1 slot 4 slot ] %
+        [ tuple-layout-superclasses ] %
-        [ n>> 2 + , [ slot ] % ]
+        [ n>> array-nth% ]
         [
             methods>> [
                 <trivial-tuple-dispatch-engine> engine>quot
@@ -104,25 +99,54 @@ M: tuple-dispatch-engine-word compiled-crossref?
     ] [ ] make ;
 
 M: echelon-dispatch-engine engine>quot
-    dup tuple-dispatch-engine-body
+    dup n>> zero? [
-    define-tuple-dispatch-engine-word
+        methods>> dup assoc-empty?
-    1quotation ;
+        [ drop default get ] [ values first engine>quot ] if
+    ] [
+        [
+            picker %
+            [ tuple-layout-superclasses ] %
+            [ n>> array-nth% ]
+            [
+                methods>> [
+                    <trivial-tuple-dispatch-engine> engine>quot
+                ] [
+                    class-hash-dispatch-quot
+                ] if-small? %
+            ] bi
+        ] [ ] make
+    ] if ;
 
 : >=-case-quot ( alist -- quot )
     default get [ drop ] prepend swap
     [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
     alist>quot ;
 
+: tuple-layout-echelon ( obj -- array )
+    { tuple } declare
+    1 slot { tuple-layout } declare
+    5 slot ; inline
+
+: unclip-last [ 1 head* ] [ peek ] bi ;
+
 M: tuple-dispatch-engine engine>quot
-    #! 1 slot == tuple-layout
-    #! 5 slot == layout-echelon
     [
         picker %
-        [ 1 slot 5 slot ] %
+        [ tuple-layout-echelon ] %
-        echelons>>
         [
             tuple assumed set
-            [ engine>quot dup default set ] assoc-map
+            echelons>> dup empty? [
+                unclip-last
+                [
+                    [
+                        engine>quot define-engine-word
+                        [ remember-engine ] [ 1quotation ] bi
+                        dup default set
+                    ] assoc-map
+                ]
+                [ first2 engine>quot 2array ] bi*
+                suffix
+            ] unless
         ] with-scope
         >=-case-quot %
     ] [ ] make ;

core/generic/standard/standard-tests.factor

@@ -3,7 +3,7 @@ USING: tools.test math math.functions math.constants
 generic.standard strings sequences arrays kernel accessors
 words float-arrays byte-arrays bit-arrays parser namespaces
 quotations inference vectors growable hashtables sbufs
-prettyprint ;
+prettyprint byte-vectors bit-vectors float-vectors ;
 
 GENERIC: lo-tag-test
 
@@ -251,6 +251,14 @@ HOOK: my-tuple-hook my-var ( -- x )
 
 M: sequence my-tuple-hook my-hook ;
 
+TUPLE: m-t-h-a ;
+
+M: m-t-h-a my-tuple-hook "foo" ;
+
+TUPLE: m-t-h-b < m-t-h-a ;
+
+M: m-t-h-b my-tuple-hook "bar" ;
+
 [ f ] [
     \ my-tuple-hook [ "engines" word-prop ] keep prefix
     [ 1quotation infer ] map all-equal?

core/inference/backend/backend-docs.factor

@@ -48,10 +48,6 @@ HELP: no-effect
 { $description "Throws a " { $link no-effect } " error." }
 { $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
 
-HELP: collect-recursion
-{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
-{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
-
 HELP: inline-word
 { $values { "word" word } }
 { $description "Called during inference to infer stack effects of inline words."

core/inference/backend/backend.factor

@@ -15,7 +15,7 @@ GENERIC: inline? ( word -- ? )
 M: method-body inline?
     "method-generic" word-prop inline? ;
 
-M: tuple-dispatch-engine-word inline?
+M: engine-word inline?
     "tuple-dispatch-generic" word-prop inline? ;
 
 M: word inline?
@@ -130,25 +130,27 @@ TUPLE: too-many->r ;
 
 TUPLE: too-many-r> ;
 
-: check-r> ( -- )
+: check-r> ( n -- )
-    meta-r get empty?
+    meta-r get length >
     [ \ too-many-r> inference-error ] when ;
 
-: infer->r ( -- )
+: infer->r ( n -- )
-    1 ensure-values
+    dup ensure-values
     #>r
-    1 0 pick node-inputs
+    over 0 pick node-inputs
-    pop-d push-r
+    over [ drop pop-d ] map reverse [ push-r ] each
-    0 1 pick node-outputs
+    0 pick pick node-outputs
-    node, ;
+    node,
+    drop ;
 
-: infer-r> ( -- )
+: infer-r> ( n -- )
-    check-r>
+    dup check-r>
     #r>
-    0 1 pick node-inputs
+    0 pick pick node-inputs
-    pop-r push-d
+    over [ drop pop-r ] map reverse [ push-d ] each
-    1 0 pick node-outputs
+    over 0 pick node-outputs
-    node, ;
+    node,
+    drop ;
 
 : undo-infer ( -- )
     recorded get [ f "inferred-effect" set-word-prop ] each ;
@@ -199,18 +201,18 @@ M: object constructor drop f ;
     dup infer-uncurry
     constructor [
         peek-d reify-curry
-        infer->r
+        1 infer->r
         peek-d reify-curry
-        infer-r>
+        1 infer-r>
         2 1 <effect> swap #call consume/produce
     ] when* ;
 
 : reify-curries ( n -- )
     meta-d get reverse [
         dup special? [
-            over [ infer->r ] times
+            over infer->r
             dup reify-curry
-            over [ infer-r> ] times
+            over infer-r>
         ] when 2drop
     ] 2each ;
 
@@ -407,6 +409,25 @@ TUPLE: recursive-declare-error word ;
         \ recursive-declare-error inference-error
     ] if* ;
 
+GENERIC: collect-label-info* ( label node -- )
+
+M: node collect-label-info* 2drop ;
+
+: (collect-label-info) ( label node vector -- )
+    >r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
+    inline
+
+M: #call-label collect-label-info*
+    over calls>> (collect-label-info) ;
+
+M: #return collect-label-info*
+    over returns>> (collect-label-info) ;
+
+: collect-label-info ( #label -- )
+    V{ } clone >>calls
+    V{ } clone >>returns
+    dup [ collect-label-info* ] with each-node ;
+
 : nest-node ( -- ) #entry node, ;
 
 : unnest-node ( new-node -- new-node )
@@ -417,27 +438,17 @@ TUPLE: recursive-declare-error word ;
 
 : <inlined-block> gensym dup t "inlined-block" set-word-prop ;
 
-: inline-block ( word -- node-block data )
+: inline-block ( word -- #label data )
     [
         copy-inference nest-node
         dup word-def swap <inlined-block>
         [ infer-quot-recursive ] 2keep
         #label unnest-node
+        dup collect-label-info
     ] H{ } make-assoc ;
 
-GENERIC: collect-recursion* ( label node -- )
+: join-values ( #label -- )
-
+    calls>> [ node-in-d ] map meta-d get suffix
-M: node collect-recursion* 2drop ;
-
-M: #call-label collect-recursion*
-    tuck node-param eq? [ , ] [ drop ] if ;
-
-: collect-recursion ( #label -- seq )
-    dup node-param
-    [ [ swap collect-recursion* ] curry each-node ] { } make ;
-
-: join-values ( node -- )
-    collect-recursion [ node-in-d ] map meta-d get suffix
     unify-lengths unify-stacks
     meta-d [ length tail* ] change ;
 
@@ -458,7 +469,7 @@ M: #call-label collect-recursion*
         drop join-values inline-block apply-infer
         r> over set-node-in-d
         dup node,
-        collect-recursion [
+        calls>> [
             [ flatten-curries ] modify-values
         ] each
     ] [

core/inference/class/class-tests.factor

@@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic
 sequences words inference.class quotations alien
 alien.c-types strings sbufs sequences.private
 slots.private combinators definitions compiler.units
-system layouts vectors ;
+system layouts vectors optimizer.math.partial accessors
+optimizer.inlining ;
+
+[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
+
+[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test
 
 ! Make sure these compile even though this is invalid code
 [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@@ -13,9 +18,15 @@ system layouts vectors ;
 ! Ensure type inference works as it is supposed to by checking
 ! if various methods get inlined
 
-: inlined? ( quot word -- ? )
+: inlined? ( quot seq/word -- ? )
+    dup word? [ 1array ] when
     swap dataflow optimize
-    [ node-param eq? ] with node-exists? not ;
+    [ node-param swap member? ] with node-exists? not ;
+
+[ f ] [
+    [ { integer } declare >fixnum ]
+    \ >fixnum inlined?
+] unit-test
 
 GENERIC: mynot ( x -- y )
 
@@ -109,12 +120,17 @@ M: object xyz ;
     [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
 ] unit-test
 
-[ f ] [
+[ t ] [
     [ { integer fixnum } declare dupd < [ 1 + ] when ]
     \ + inlined?
 ] unit-test
 
-[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test
+[ f ] [
+    [ { integer fixnum } declare dupd < [ 1 + ] when ]
+    \ +-integer-fixnum inlined?
+] unit-test
+
+[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
 
 [ f ] [
     [
@@ -137,13 +153,13 @@ M: object xyz ;
 
 DEFER: blah
 
-[ t ] [
+[ ] [
     [
         \ blah
         [ dup V{ } eq? [ foo ] when ] dup second dup push define
     ] with-compilation-unit
 
-    \ blah compiled?
+    \ blah word-def dataflow optimize drop
 ] unit-test
 
 GENERIC: detect-fx ( n -- n )
@@ -158,14 +174,20 @@ M: fixnum detect-fx ;
     ] \ detect-fx inlined?
 ] unit-test
 
+[ t ] [
+    [
+        1000000000000000000000000000000000 [ ] times
+    ] \ + inlined?
+] unit-test
 [ f ] [
     [
         1000000000000000000000000000000000 [ ] times
-    ] \ 1+ inlined?
+    ] \ +-integer-fixnum inlined?
 ] unit-test
 
 [ f ] [
-    [ { bignum } declare [ ] times ] \ 1+ inlined?
+    [ { bignum } declare [ ] times ]
+    \ +-integer-fixnum inlined?
 ] unit-test
 
 
@@ -251,19 +273,24 @@ M: float detect-float ;
     [ 3 + = ] \ equal? inlined?
 ] unit-test
 
-[ t ] [
+[ f ] [
     [ { fixnum fixnum } declare 7 bitand neg shift ]
-    \ shift inlined?
+    \ fixnum-shift-fast inlined?
 ] unit-test
 
 [ t ] [
     [ { fixnum fixnum } declare 7 bitand neg shift ]
-    \ fixnum-shift inlined?
+    { shift fixnum-shift } inlined?
 ] unit-test
 
 [ t ] [
     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
-    \ fixnum-shift inlined?
+    { shift fixnum-shift } inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
+    { fixnum-shift-fast } inlined?
 ] unit-test
 
 cell-bits 32 = [
@@ -278,6 +305,11 @@ cell-bits 32 = [
     ] unit-test
 ] when
 
+[ f ] [
+    [ { integer } declare -63 shift 4095 bitand ]
+    \ shift inlined?
+] unit-test
+
 [ t ] [
     [ B{ 1 0 } *short 0 number= ]
     \ number= inlined?
@@ -323,3 +355,228 @@ cell-bits 32 = [
         ] when
     ] \ + inlined?
 ] unit-test
+
+[ f ] [
+    [
+        256 mod
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ f ] [
+    [
+        dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 256 rem
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare [ 256 rem ] map
+    ] { mod fixnum-mod rem } inlined?
+] unit-test
+
+[ t ] [
+    [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+] unit-test
+
+: rec ( a -- b )
+    dup 0 > [ 1 - rec ] when ; inline
+
+[ t ] [
+    [ { fixnum } declare rec 1 + ]
+    { > - + } inlined?
+] unit-test
+
+: fib ( m -- n )
+    dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
+
+[ t ] [
+    [ 27.0 fib ] { < - + } inlined?
+] unit-test
+
+[ f ] [
+    [ 27.0 fib ] { +-integer-integer } inlined?
+] unit-test
+
+[ t ] [
+    [ 27 fib ] { < - + } inlined?
+] unit-test
+
+[ t ] [
+    [ 27 >bignum fib ] { < - + } inlined?
+] unit-test
+
+[ f ] [
+    [ 27/2 fib ] { < - } inlined?
+] unit-test
+
+: hang-regression ( m n -- x )
+    over 0 number= [
+        nip
+    ] [
+        dup [
+            drop 1 hang-regression
+        ] [
+            dupd hang-regression hang-regression
+        ] if
+    ] if ; inline
+
+[ t ] [
+    [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
+] { } inlined? ] unit-test
+
+: detect-null ( a -- b ) dup drop ;
+
+\ detect-null {
+    { [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] }
+} define-optimizers
+
+[ t ] [
+    [ { null } declare detect-null ] \ detect-null inlined?
+] unit-test
+
+[ t ] [
+    [ { null null } declare + detect-null ] \ detect-null inlined?
+] unit-test
+
+[ f ] [
+    [ { null fixnum } declare + detect-null ] \ detect-null inlined?
+] unit-test
+
+GENERIC: detect-integer ( a -- b )
+
+M: integer detect-integer ;
+
+[ t ] [
+    [ { null fixnum } declare + detect-integer ] \ detect-integer inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
+    \ fixnum-bitand inlined?
+] unit-test
+
+[ t ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ drop ] each-integer ]
+    { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare length [ drop ] each-integer ]
+    { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ drop ] each ]
+    { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare 0 [ + ] reduce ]
+    { < <-integer-fixnum } inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum } declare 0 [ + ] reduce ]
+    \ +-integer-fixnum inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare
+        dup 0 >= [
+            615949 * 797807 + 20 2^ mod dup 19 2^ -
+        ] [ dup ] if
+    ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare
+        615949 * 797807 + 20 2^ mod dup 19 2^ -
+    ] { >fixnum } inlined?
+] unit-test
+
+[ f ] [
+    [
+        { integer } declare [ ] map
+    ] \ >fixnum inlined?
+] unit-test
+
+[ f ] [
+    [
+        { integer } declare { } set-nth-unsafe
+    ] \ >fixnum inlined?
+] unit-test
+
+[ f ] [
+    [
+        { integer } declare 1 + { } set-nth-unsafe
+    ] \ >fixnum inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { integer } declare bitnot detect-integer ]
+    \ detect-integer inlined?
+] unit-test
+
+! Later
+
+! [ t ] [
+!     [
+!         { integer } declare [ 256 mod ] map
+!     ] { mod fixnum-mod } inlined?
+! ] unit-test
+! 
+! [ t ] [
+!     [
+!         { integer } declare [ 0 >= ] map
+!     ] { >= fixnum>= } inlined?
+! ] unit-test

core/inference/class/class.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs hashtables inference kernel
 math namespaces sequences words parser math.intervals
 effects classes classes.algebra inference.dataflow
-inference.backend combinators ;
+inference.backend combinators accessors ;
 IN: inference.class
 
 ! Class inference
@@ -25,12 +25,10 @@ C: <literal-constraint> literal-constraint
 
 M: literal-constraint equal?
     over literal-constraint? [
-        2dup
+        [ [ literal>> ] bi@ eql? ]
-        [ literal-constraint-literal ] bi@ eql? >r
+        [ [ value>>   ] bi@ =    ]
-        [ literal-constraint-value ] bi@ = r> and
+        2bi and
-    ] [
+    ] [ 2drop f ] if ;
-        2drop f
-    ] if ;
 
 TUPLE: class-constraint class value ;
 
@@ -43,8 +41,8 @@ C: <interval-constraint> interval-constraint
 GENERIC: apply-constraint ( constraint -- )
 GENERIC: constraint-satisfied? ( constraint -- ? )
 
-: `input node get node-in-d nth ;
+: `input node get in-d>> nth ;
-: `output node get node-out-d nth ;
+: `output node get out-d>> nth ;
 : class, <class-constraint> , ;
 : literal, <literal-constraint> , ;
 : interval, <interval-constraint> , ;
@@ -84,14 +82,12 @@ SYMBOL: value-classes
     set-value-interval* ;
 
 M: interval-constraint apply-constraint
-    dup interval-constraint-interval
+    [ interval>> ] [ value>> ] bi intersect-value-interval ;
-    swap interval-constraint-value intersect-value-interval ;
 
 : set-class-interval ( class value -- )
     over class? [
-        over "interval" word-prop [
+        >r "interval" word-prop r> over
-            >r "interval" word-prop r> set-value-interval*
+        [ set-value-interval* ] [ 2drop ] if
-        ] [ 2drop ] if
     ] [ 2drop ] if ;
 
 : value-class* ( value -- class )
@@ -110,18 +106,21 @@ M: interval-constraint apply-constraint
     [ value-class* class-and ] keep set-value-class* ;
 
 M: class-constraint apply-constraint
-    dup class-constraint-class
+    [ class>> ] [ value>> ] bi intersect-value-class ;
-    swap class-constraint-value intersect-value-class ;
+
+: literal-interval ( value -- interval/f )
+    dup real? [ [a,a] ] [ drop f ] if ;
 
 : set-value-literal* ( literal value -- )
-    over class over set-value-class*
+    {
-    over real? [ over [a,a] over set-value-interval* ] when
+        [ >r class r> set-value-class* ]
-    2dup <literal-constraint> assume
+        [ >r literal-interval r> set-value-interval* ]
-    value-literals get set-at ;
+        [ <literal-constraint> assume ]
+        [ value-literals get set-at ]
+    } 2cleave ;
 
 M: literal-constraint apply-constraint
-    dup literal-constraint-literal
+    [ literal>> ] [ value>> ] bi set-value-literal* ;
-    swap literal-constraint-value set-value-literal* ;
 
 ! For conditionals, an assoc of child node # --> constraint
 GENERIC: child-constraints ( node -- seq )
@@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- )
 M: node infer-classes-before drop ;
 
 M: node child-constraints
-    node-children length
+    children>> length
     dup zero? [ drop f ] [ f <repetition> ] if ;
 
 : value-literal* ( value -- obj ? )
     value-literals get at* ;
 
 M: literal-constraint constraint-satisfied?
-    dup literal-constraint-value value-literal*
+    dup value>> value-literal*
-    [ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
+    [ swap literal>> eql? ] [ 2drop f ] if ;
 
 M: class-constraint constraint-satisfied?
-    dup class-constraint-value value-class*
+    [ value>> value-class* ] [ class>> ] bi class< ;
-    swap class-constraint-class class< ;
 
 M: pair apply-constraint
     first2 2dup constraints get set-at
@@ -154,19 +152,18 @@ M: pair apply-constraint
 M: pair constraint-satisfied?
     first constraint-satisfied? ;
 
-: extract-keys ( assoc seq -- newassoc )
+: extract-keys ( seq assoc -- newassoc )
-    dup length <hashtable> swap [
+    [ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
-        dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
-    ] each nip f assoc-like ;
 
 : annotate-node ( node -- )
     #! Annotate the node with the currently-inferred set of
     #! value classes.
-    dup node-values
+    dup node-values {
-    value-intervals get over extract-keys pick set-node-intervals
+        [ value-intervals get extract-keys >>intervals ]
-    value-classes get over extract-keys pick set-node-classes
+        [ value-classes   get extract-keys >>classes   ]
-    value-literals get over extract-keys pick set-node-literals
+        [ value-literals  get extract-keys >>literals  ]
-    2drop ;
+        [ 2drop ]
+    } cleave ;
 
 : intersect-classes ( classes values -- )
     [ intersect-value-class ] 2each ;
@@ -190,31 +187,29 @@ M: pair constraint-satisfied?
     ] 2bi ;
 
 : compute-constraints ( #call -- )
-    dup node-param "constraints" word-prop [
+    dup param>> "constraints" word-prop [
         call
     ] [
-        dup node-param "predicating" word-prop dup
+        dup param>> "predicating" word-prop dup
         [ swap predicate-constraints ] [ 2drop ] if
     ] if* ;
 
 : compute-output-classes ( node word -- classes intervals )
-    dup node-param "output-classes" word-prop
+    dup param>> "output-classes" word-prop
     dup [ call ] [ 2drop f f ] if ;
 
 : output-classes ( node -- classes intervals )
     dup compute-output-classes >r
-    [ ] [ node-param "default-output-classes" word-prop ] ?if
+    [ ] [ param>> "default-output-classes" word-prop ] ?if
     r> ;
 
 M: #call infer-classes-before
-    dup compute-constraints
+    [ compute-constraints ] keep
-    dup node-out-d swap output-classes
+    [ output-classes ] [ out-d>> ] bi
-    >r over intersect-classes
+    tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
-    r> swap intersect-intervals ;
 
 M: #push infer-classes-before
-    node-out-d
+    out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
-    [ [ value-literal ] keep set-value-literal* ] each ;
 
 M: #if child-constraints
     [
@@ -224,19 +219,17 @@ M: #if child-constraints
 
 M: #dispatch child-constraints
     dup [
-        node-children length [
+        children>> length [ 0 `input literal, ] each
-            0 `input literal,
-        ] each
     ] make-constraints ;
 
 M: #declare infer-classes-before
-    dup node-param swap node-in-d
+    [ param>> ] [ in-d>> ] bi
     [ intersect-value-class ] 2each ;
 
 DEFER: (infer-classes)
 
 : infer-children ( node -- )
-    dup node-children swap child-constraints [
+    [ children>> ] [ child-constraints ] bi [
         [
             value-classes [ clone ] change
             value-literals [ clone ] change
@@ -251,27 +244,27 @@ DEFER: (infer-classes)
     >r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
 
 : (merge-classes) ( nodes -- seq )
-    [ node-input-classes ] map
+    dup length 1 = [
-    null pad-all flip [ null [ class-or ] reduce ] map ;
+        first node-input-classes
+    ] [
+        [ node-input-classes ] map null pad-all flip
+        [ null [ class-or ] reduce ] map
+    ] if ;
 
 : set-classes ( seq node -- )
-    node-out-d [ set-value-class* ] 2reverse-each ;
+    out-d>> [ set-value-class* ] 2reverse-each ;
 
 : merge-classes ( nodes node -- )
     >r (merge-classes) r> set-classes ;
 
-: (merge-intervals) ( nodes quot -- seq )
-    >r
-    [ node-input-intervals ] map
-    f pad-all flip
-    r> map ; inline
-
 : set-intervals ( seq node -- )
-    node-out-d [ set-value-interval* ] 2reverse-each ;
+    out-d>> [ set-value-interval* ] 2reverse-each ;
 
 : merge-intervals ( nodes node -- )
-    >r [ dup first [ interval-union ] reduce ]
+    >r
-    (merge-intervals) r> set-intervals ;
+    [ node-input-intervals ] map f pad-all flip
+    [ dup first [ interval-union ] reduce ] map
+    r> set-intervals ;
 
 : annotate-merge ( nodes #merge/#entry -- )
     [ merge-classes ] [ merge-intervals ] 2bi ;
@@ -280,28 +273,68 @@ DEFER: (infer-classes)
     dup node-successor dup #merge? [
         swap active-children dup empty?
         [ 2drop ] [ swap annotate-merge ] if
-    ] [
+    ] [ 2drop ] if ;
-        2drop
+
-    ] if ;
+: classes= ( inferred current -- ? )
+    2dup min-length [ tail* ] curry bi@ sequence= ;
+
+SYMBOL: fixed-point?
+
+SYMBOL: nested-labels
 
 : annotate-entry ( nodes #label -- )
-    node-child merge-classes ;
+    >r (merge-classes) r> node-child
+    2dup node-output-classes classes=
+    [ 2drop ] [ set-classes fixed-point? off ] if ;
+
+: init-recursive-calls ( #label -- )
+    #! We set recursive calls to output the empty type, then
+    #! repeat inference until a fixed point is reached.
+    #! Hopefully, our type functions are monotonic so this
+    #! will always converge.
+    returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
 
 M: #label infer-classes-before ( #label -- )
-    #! First, infer types under the hypothesis which hold on
+    [ init-recursive-calls ]
-    #! entry to the recursive label.
+    [ [ 1array ] keep annotate-entry ] bi ;
-    [ 1array ] keep annotate-entry ;
+
+: infer-label-loop ( #label -- )
+    fixed-point? on
+    dup node-child (infer-classes)
+    dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
+    fixed-point? get [ drop ] [ infer-label-loop ] if ;
 
 M: #label infer-classes-around ( #label -- )
     #! Now merge the types at every recursion point with the
     #! entry types.
+    [
         {
+            [ nested-labels get push ]
             [ annotate-node ]
             [ infer-classes-before ]
-        [ infer-children ]
+            [ infer-label-loop ]
-        [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
+            [ drop nested-labels get pop* ]
-        [ node-child (infer-classes) ]
+        } cleave
-    } cleave ;
+    ] with-scope ;
+
+: find-label ( param -- #label )
+    param>> nested-labels get [ param>> eq? ] with find nip ;
+
+M: #call-label infer-classes-before ( #call-label -- )
+    [ find-label returns>> (merge-classes) ] [ out-d>> ] bi
+    [ set-value-class* ] 2each ;
+
+M: #return infer-classes-around
+    nested-labels get length 0 > [
+        dup param>> nested-labels get peek param>> eq? [
+            [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
+            classes= not [
+                fixed-point? off
+                [ in-d>> value-classes get extract-keys ] keep
+                set-node-classes
+            ] [ drop ] if
+        ] [ call-next-method ] if
+    ] [ call-next-method ] if ;
 
 M: object infer-classes-around
     {
@@ -314,11 +347,13 @@ M: object infer-classes-around
 : (infer-classes) ( node -- )
     [
         [ infer-classes-around ]
-        [ node-successor (infer-classes) ] bi
+        [ node-successor ] bi
+        (infer-classes)
     ] when* ;
 
 : infer-classes-with ( node classes literals intervals -- )
     [
+        V{ } clone nested-labels set
         H{ } assoc-like value-intervals set
         H{ } assoc-like value-literals set
         H{ } assoc-like value-classes set
@@ -326,13 +361,11 @@ M: object infer-classes-around
         (infer-classes)
     ] with-scope ;
 
-: infer-classes ( node -- )
+: infer-classes ( node -- node )
-    f f f infer-classes-with ;
+    dup f f f infer-classes-with ;
 
 : infer-classes/node ( node existing -- )
     #! Infer classes, using the existing node's class info as a
     #! starting point.
-    dup node-classes
+    [ classes>> ] [ literals>> ] [ intervals>> ] tri
-    over node-literals
-    rot node-intervals
     infer-classes-with ;

core/inference/dataflow/dataflow.factor

@@ -90,7 +90,7 @@ M: object flatten-curry , ;
 
 : node-child node-children first ;
 
-TUPLE: #label < node word loop? ;
+TUPLE: #label < node word loop? returns calls ;
 
 : #label ( word label -- node )
     \ #label param-node swap >>word ;
@@ -290,6 +290,9 @@ SYMBOL: node-stack
 : node-input-classes ( node -- seq )
     dup in-d>> [ node-class ] with map ;
 
+: node-output-classes ( node -- seq )
+    dup out-d>> [ node-class ] with map ;
+
 : node-input-intervals ( node -- seq )
     dup in-d>> [ node-interval ] with map ;
 

core/inference/known-words/known-words.factor

@@ -54,9 +54,9 @@ IN: inference.known-words
     { swap  T{ effect f 2 { 1 0         } } }
 } [ define-shuffle ] assoc-each
 
-\ >r [ infer->r ] "infer" set-word-prop
+\ >r [ 1 infer->r ] "infer" set-word-prop
 
-\ r> [ infer-r> ] "infer" set-word-prop
+\ r> [ 1 infer-r> ] "infer" set-word-prop
 
 \ declare [
     1 ensure-values
@@ -81,8 +81,8 @@ M: curried infer-call
 
 M: composed infer-call
     infer-uncurry
-    infer->r peek-d infer-call
+    1 infer->r peek-d infer-call
-    terminated? get [ infer-r> peek-d infer-call ] unless ;
+    terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
 
 M: object infer-call
     \ literal-expected inference-warning ;
@@ -92,6 +92,8 @@ M: object infer-call
     peek-d infer-call
 ] "infer" set-word-prop
 
+\ call t "no-compile" set-word-prop
+
 \ execute [
     1 ensure-values
     pop-literal nip
@@ -471,18 +473,6 @@ set-primitive-effect
 
 \ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>char-string make-flushable
-
-\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>char-alien make-flushable
-
-\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>u16-string make-flushable
-
-\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>u16-alien make-flushable
-
 \ alien-address { alien } { integer } <effect> set-primitive-effect
 \ alien-address make-flushable
 

core/io/encodings/encodings-docs.factor

@@ -41,12 +41,13 @@ $low-level-note ;
 
 ARTICLE: "encodings-descriptors" "Encoding descriptors"
 "An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
-{ $vocab-subsection "ASCII" "io.encodings.ascii" }
+{ $subsection "io.encodings.binary" }
-{ $vocab-subsection "Binary" "io.encodings.binary" }
+{ $subsection "io.encodings.utf8" }
+{ $subsection "io.encodings.utf16" }
 { $vocab-subsection "Strict encodings" "io.encodings.strict" }
+"Legacy encodings:"
 { $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
-{ $vocab-subsection "UTF-8" "io.encodings.utf8" }
+{ $vocab-subsection "ASCII" "io.encodings.ascii" }
-{ $vocab-subsection "UTF-16" "io.encodings.utf16" }
 { $see-also "encodings-introduction" } ;
 
 ARTICLE: "encodings-protocol" "Encoding protocol"

core/io/encodings/utf16/utf16-docs.factor

@@ -5,8 +5,7 @@ ARTICLE: "io.encodings.utf16" "UTF-16"
 "The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
 { $subsection utf16 }
 { $subsection utf16le }
-{ $subsection utf16be }
+{ $subsection utf16be } ;
-{ $subsection utf16n } ;
 
 ABOUT: "io.encodings.utf16"
 
@@ -22,8 +21,4 @@ HELP: utf16
 { $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
 { $see-also "encodings-introduction" } ;
 
-HELP: utf16n
+{ utf16 utf16le utf16be } related-words
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
-{ $see-also "encodings-introduction" } ;
-
-{ utf16 utf16le utf16be utf16n } related-words

core/io/encodings/utf16/utf16-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel tools.test io.encodings.utf16 arrays sbufs
 io.streams.byte-array sequences io.encodings io unicode
-io.encodings.string alien.c-types accessors classes ;
+io.encodings.string alien.c-types alien.strings accessors classes ;
 IN: io.encodings.utf16.tests
 
 [ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test

core/io/encodings/utf16/utf16.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2006, 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays inspector
+io.encodings combinators splitting io byte-arrays inspector ;
-alien.c-types ;
 IN: io.encodings.utf16
 
 TUPLE: utf16be ;
@@ -11,8 +10,6 @@ TUPLE: utf16le ;
 
 TUPLE: utf16 ;
 
-TUPLE: utf16n ;
-
 <PRIVATE
 
 ! UTF-16BE decoding
@@ -124,13 +121,4 @@ M: utf16 <decoder> ( stream utf16 -- decoder )
 M: utf16 <encoder> ( stream utf16 -- encoder )
     drop bom-le over stream-write utf16le <encoder> ;
 
-! Native-order UTF-16
-
-: native-utf16 ( -- descriptor )
-    little-endian? utf16le utf16be ? ;
-
-M: utf16n <decoder> drop native-utf16 <decoder> ;
-
-M: utf16n <encoder> drop native-utf16 <encoder> ;
-
 PRIVATE>

core/io/streams/memory/memory.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors alien.accessors math io ;
+IN: io.streams.memory
+
+TUPLE: memory-stream alien index ;
+
+: <memory-stream> ( alien -- stream )
+    0 memory-stream boa ;
+
+M: memory-stream stream-read1
+    [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
+    [ [ 1+ ] change-index drop ] bi ;

core/math/integers/integers-tests.factor

@@ -184,3 +184,10 @@ unit-test
 [ HEX: 988a259c3433f237 ] [
     B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum
 ] unit-test
+
+[ t ] [ 256 power-of-2? ] unit-test
+[ f ] [ 123 power-of-2? ] unit-test
+
+[ f ] [ -128 power-of-2? ] unit-test
+[ f ] [ 0 power-of-2? ] unit-test
+[ t ] [ 1 power-of-2? ] unit-test

core/math/intervals/intervals.factor

@@ -96,6 +96,8 @@ C: <interval> interval
 
 : interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
 
+: interval-sq ( i1 -- i2 ) dup interval* ;
+
 : make-interval ( from to -- int )
     over first over first {
         { [ 2dup > ] [ 2drop 2drop f ] }

core/math/math-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel sequences quotations
-math.private math.functions ;
+math.private ;
 IN: math
 
 ARTICLE: "division-by-zero" "Division by zero"
@@ -26,17 +26,13 @@ $nl
 { $subsection < }
 { $subsection <= }
 { $subsection > }
-{ $subsection >= }
+{ $subsection >= } ;
-"Inexact comparison:"
-{ $subsection ~ } ;
 
 ARTICLE: "modular-arithmetic" "Modular arithmetic"
 { $subsection mod }
 { $subsection rem }
 { $subsection /mod }
 { $subsection /i }
-{ $subsection mod-inv }
-{ $subsection ^mod }
 { $see-also "integer-functions" } ;
 
 ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
@@ -363,6 +359,10 @@ HELP: next-power-of-2
 { $values { "m" "a non-negative integer" } { "n" "an integer" } }
 { $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
 
+HELP: power-of-2?
+{ $values { "n" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
+
 HELP: each-integer
 { $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } }
 { $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }

core/math/math.factor

@@ -55,26 +55,26 @@ GENERIC: zero? ( x -- ? ) foldable
 
 M: object zero? drop f ;
 
-: 1+ ( x -- y ) 1 + ; foldable
+: 1+ ( x -- y ) 1 + ; inline
-: 1- ( x -- y ) 1 - ; foldable
+: 1- ( x -- y ) 1 - ; inline
-: 2/ ( x -- y ) -1 shift ; foldable
+: 2/ ( x -- y ) -1 shift ; inline
-: sq ( x -- y ) dup * ; foldable
+: sq ( x -- y ) dup * ; inline
-: neg ( x -- -x ) 0 swap - ; foldable
+: neg ( x -- -x ) 0 swap - ; inline
-: recip ( x -- y ) 1 swap / ; foldable
+: recip ( x -- y ) 1 swap / ; inline
 
 : ?1+ [ 1+ ] [ 0 ] if* ; inline
 
 : /f  ( x y -- z ) >r >float r> >float float/f ; inline
 
-: max ( x y -- z ) [ > ] most ; foldable
+: max ( x y -- z ) [ > ] most ; inline
-: min ( x y -- z ) [ < ] most ; foldable
+: min ( x y -- z ) [ < ] most ; inline
 
 : between? ( x y z -- ? )
     pick >= [ >= ] [ 2drop f ] if ; inline
 
 : rem ( x y -- z ) tuck mod over + swap mod ; foldable
 
-: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
+: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
 
 : [-] ( x y -- z ) - 0 max ; inline
 
@@ -121,7 +121,11 @@ M: float fp-nan?
 
 : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
 
-: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
+: power-of-2? ( n -- ? )
+    dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
+
+: align ( m w -- n )
+    1- [ + ] keep bitnot bitand ; inline
 
 <PRIVATE
 

core/optimizer/backend/backend.factor

@@ -3,7 +3,7 @@
 USING: arrays generic assocs inference inference.class
 inference.dataflow inference.backend inference.state io kernel
 math namespaces sequences vectors words quotations hashtables
-combinators classes optimizer.def-use ;
+combinators classes optimizer.def-use accessors ;
 IN: optimizer.backend
 
 SYMBOL: class-substitutions
@@ -16,37 +16,32 @@ SYMBOL: optimizer-changed
 
 GENERIC: optimize-node* ( node -- node/t changed? )
 
-: ?union ( assoc/f assoc -- hash )
+: ?union ( assoc assoc/f -- assoc' )
-    over [ assoc-union ] [ nip ] if ;
+    dup assoc-empty? [ drop ] [ swap assoc-union ] if ;
 
-: add-node-literals ( assoc node -- )
+: add-node-literals ( node assoc -- )
-    over assoc-empty? [
+    [ ?union ] curry change-literals drop ;
+
+: add-node-classes ( node assoc -- )
+    [ ?union ] curry change-classes drop ;
+
+: substitute-values ( node assoc -- )
+    dup assoc-empty? [
         2drop
     ] [
-        [ node-literals ?union ] keep set-node-literals
+        {
-    ] if ;
+            [ >r  in-d>> r> substitute-here ]
-
+            [ >r  in-r>> r> substitute-here ]
-: add-node-classes ( assoc node -- )
+            [ >r out-d>> r> substitute-here ]
-    over assoc-empty? [
+            [ >r out-r>> r> substitute-here ]
-        2drop
+        } 2cleave
-    ] [
-        [ node-classes ?union ] keep set-node-classes
-    ] if ;
-
-: substitute-values ( assoc node -- )
-    over assoc-empty? [
-        2drop
-    ] [
-        2dup node-in-d swap substitute-here
-        2dup node-in-r swap substitute-here
-        2dup node-out-d swap substitute-here
-        node-out-r swap substitute-here
     ] if ;
 
 : perform-substitutions ( node -- )
-    class-substitutions get over add-node-classes
+    [   class-substitutions get add-node-classes  ]
-    literal-substitutions get over add-node-literals
+    [ literal-substitutions get add-node-literals ]
-    value-substitutions get swap substitute-values ;
+    [   value-substitutions get substitute-values ]
+    tri ;
 
 DEFER: optimize-nodes
 
@@ -90,18 +85,21 @@ M: node optimize-node* drop t f ;
     #! Not very efficient.
     dupd union* update ;
 
-: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
+: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
-    node-out-d swap node-in-d 2array unify-lengths flip
+    [ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
     [ = not ] assoc-subset >hashtable ;
 
 : cleanup-inlining ( #return/#values -- newnode changed? )
-    dup node-successor dup [
+    dup node-successor [
-        class-substitutions get pick node-classes update
+        [ node-successor ] keep
-        literal-substitutions get pick node-literals update
+        {
-        tuck compute-value-substitutions value-substitutions get swap update*
+            [ nip classes>> class-substitutions get swap update ]
-        node-successor t
+            [ nip literals>> literal-substitutions get swap update ]
+            [ compute-value-substitutions value-substitutions get swap update* ]
+            [ drop node-successor ]
+        } 2cleave t
     ] [
-        2drop t f
+        drop t f
     ] if ;
 
 ! #return

core/optimizer/collect/collect.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: inference.dataflow inference.backend kernel ;
+IN: optimizer
+
+: collect-label-infos ( node -- node )
+    dup [
+        dup #label? [ collect-label-info ] [ drop ] if
+    ] each-node ;
+

core/optimizer/control/control-tests.factor

@@ -27,22 +27,22 @@ optimizer ;
     dup [ 1+ loop-test-1 ] [ drop ] if ; inline
                           
 [ t ] [
-    [ loop-test-1 ] dataflow dup detect-loops
+    [ loop-test-1 ] dataflow detect-loops
     \ loop-test-1 label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ loop-test-1 1 2 3 ] dataflow dup detect-loops
+    [ loop-test-1 1 2 3 ] dataflow detect-loops
     \ loop-test-1 label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ [ loop-test-1 ] each ] dataflow dup detect-loops
+    [ [ loop-test-1 ] each ] dataflow detect-loops
     \ loop-test-1 label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ [ loop-test-1 ] each ] dataflow dup detect-loops
+    [ [ loop-test-1 ] each ] dataflow detect-loops
     \ (each-integer) label-is-loop?
 ] unit-test
 
@@ -50,7 +50,7 @@ optimizer ;
     dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
 
 [ t ] [
-    [ loop-test-2 ] dataflow dup detect-loops
+    [ loop-test-2 ] dataflow detect-loops
     \ loop-test-2 label-is-not-loop?
 ] unit-test
 
@@ -58,7 +58,7 @@ optimizer ;
     dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
 
 [ t ] [
-    [ loop-test-3 ] dataflow dup detect-loops
+    [ loop-test-3 ] dataflow detect-loops
     \ loop-test-3 label-is-not-loop?
 ] unit-test
 
@@ -73,7 +73,7 @@ optimizer ;
     dup #label? [ node-successor find-label ] unless ;
 
 : test-loop-exits
-    dataflow dup detect-loops find-label
+    dataflow detect-loops find-label
     dup node-param swap
     [ node-child find-tail find-loop-exits [ class ] map ] keep
     #label-loop? ;
@@ -113,7 +113,7 @@ optimizer ;
 ] unit-test
 
 [ f ] [
-    [ [ [ ] map ] map ] dataflow dup detect-loops
+    [ [ [ ] map ] map ] dataflow detect-loops
     [ dup #label? swap #loop? not and ] node-exists?
 ] unit-test
 
@@ -128,22 +128,22 @@ DEFER: a
     blah [ b ] [ a ] if ; inline
 
 [ t ] [
-    [ a ] dataflow dup detect-loops
+    [ a ] dataflow detect-loops
     \ a label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ a ] dataflow dup detect-loops
+    [ a ] dataflow detect-loops
     \ b label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ b ] dataflow dup detect-loops
+    [ b ] dataflow detect-loops
     \ a label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ a ] dataflow dup detect-loops
+    [ a ] dataflow detect-loops
     \ b label-is-loop?
 ] unit-test
 
@@ -156,12 +156,12 @@ DEFER: a'
     blah [ b' ] [ a' ] if ; inline
 
 [ f ] [
-    [ a' ] dataflow dup detect-loops
+    [ a' ] dataflow detect-loops
     \ a' label-is-loop?
 ] unit-test
 
 [ f ] [
-    [ b' ] dataflow dup detect-loops
+    [ b' ] dataflow detect-loops
     \ b' label-is-loop?
 ] unit-test
 
@@ -171,11 +171,11 @@ DEFER: a'
 ! a standard iterative dataflow problem after all -- so I'm
 ! tempted to believe the computer here
 [ t ] [
-    [ b' ] dataflow dup detect-loops
+    [ b' ] dataflow detect-loops
     \ a' label-is-loop?
 ] unit-test
 
 [ f ] [
-    [ a' ] dataflow dup detect-loops
+    [ a' ] dataflow detect-loops
     \ b' label-is-loop?
 ] unit-test

core/optimizer/control/control.factor

@@ -109,8 +109,9 @@ SYMBOL: potential-loops
         ] [ 2drop ] if
     ] assoc-each [ remove-non-loop-calls ] when ;
 
-: detect-loops ( nodes -- )
+: detect-loops ( node -- node )
     [
+        dup
         collect-label-info
         remove-non-tail-calls
         remove-non-loop-calls

core/optimizer/def-use/def-use-tests.factor

@@ -3,12 +3,12 @@ USING: inference inference.dataflow optimizer optimizer.def-use
 namespaces assocs kernel sequences math tools.test words ;
 
 [ 3 { 1 1 1 } ] [
-    [ 1 2 3 ] dataflow compute-def-use
+    [ 1 2 3 ] dataflow compute-def-use drop
     def-use get values dup length swap [ length ] map
 ] unit-test
 
 : kill-set ( quot -- seq )
-    dataflow compute-def-use compute-dead-literals keys
+    dataflow compute-def-use drop compute-dead-literals keys
     [ value-literal ] map ;
 
 : subset? [ member? ] curry all? ;

core/optimizer/def-use/def-use.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: optimizer.def-use
 USING: namespaces assocs sequences inference.dataflow
-inference.backend kernel generic assocs classes vectors ;
+inference.backend kernel generic assocs classes vectors
+accessors combinators ;
+IN: optimizer.def-use
 
 SYMBOL: def-use
 
@@ -21,17 +22,20 @@ SYMBOL: def-use
 
 GENERIC: node-def-use ( node -- )
 
-: compute-def-use ( node -- )
+: compute-def-use ( node -- node )
-    H{ } clone def-use set [ node-def-use ] each-node ;
+    H{ } clone def-use set
+    dup [ node-def-use ] each-node ;
 
 : nest-def-use ( node -- def-use )
-    [ compute-def-use def-use get ] with-scope ;
+    [ compute-def-use drop def-use get ] with-scope ;
 
 : (node-def-use) ( node -- )
-    dup dup node-in-d uses-values
+    {
-    dup dup node-in-r uses-values
+        [ dup in-d>> uses-values ] 
-    dup node-out-d defs-values
+        [ dup in-r>> uses-values ] 
-    node-out-r defs-values ;
+        [ out-d>>    defs-values ] 
+        [ out-r>>    defs-values ]
+    } cleave ;
 
 M: object node-def-use (node-def-use) ;
 
@@ -43,7 +47,7 @@ M: #passthru node-def-use drop ;
 
 M: #return node-def-use
     #! Values returned by local labels can be killed.
-    dup node-param [ drop ] [ (node-def-use) ] if ;
+    dup param>> [ drop ] [ (node-def-use) ] if ;
 
 ! nodes that don't use their values directly
 UNION: #killable
@@ -56,13 +60,13 @@ UNION: #killable
 
 M: #label node-def-use
     [
-        dup node-in-d ,
+        dup in-d>> ,
-        dup node-child node-out-d ,
+        dup node-child out-d>> ,
-        dup collect-recursion [ node-in-d , ] each
+        dup calls>> [ in-d>> , ] each
     ] { } make purge-invariants uses-values ;
 
 : branch-def-use ( #branch -- )
-    active-children [ node-in-d ] map
+    active-children [ in-d>> ] map
     purge-invariants t swap uses-values ;
 
 M: #branch node-def-use
@@ -85,16 +89,16 @@ M: node kill-node* drop t ;
     inline
 
 M: #shuffle kill-node* 
-    [
+    [ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ;
-        dup node-in-d empty? swap node-out-d empty? and
-    ] prune-if ;
 
 M: #push kill-node* 
-    [ node-out-d empty? ] prune-if ;
+    [ out-d>> empty? ] prune-if ;
 
-M: #>r kill-node* [ node-in-d empty? ] prune-if ;
+M: #>r kill-node*
+    [ in-d>> empty? ] prune-if ;
 
-M: #r> kill-node* [ node-in-r empty? ] prune-if ;
+M: #r> kill-node*
+    [ in-r>> empty? ] prune-if ;
 
 : kill-node ( node -- node )
     dup [
@@ -116,7 +120,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
     ] if ;
 
 : sole-consumer ( #call -- node/f )
-    node-out-d first used-by
+    out-d>> first used-by
     dup length 1 = [ first ] [ drop f ] if ;
 
 : splice-def-use ( node -- )
@@ -128,5 +132,5 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
     #! degree of accuracy; the new values should be marked as
     #! having _some_ usage, so that flushing doesn't erronously
     #! flush them away.
-    [ compute-def-use def-use get keys ] with-scope
+    nest-def-use keys
     def-use get [ [ t swap ?push ] change-at ] curry each ;

core/optimizer/inlining/inlining-tests.factor

@@ -0,0 +1,10 @@
+IN: optimizer.inlining.tests
+USING: tools.test optimizer.inlining ;
+
+\ word-flat-length must-infer
+
+\ inlining-math-method must-infer
+
+\ optimistic-inline? must-infer
+
+\ find-identity must-infer

core/optimizer/inlining/inlining.factor

@@ -3,10 +3,11 @@
 USING: arrays generic assocs inference inference.class
 inference.dataflow inference.backend inference.state io kernel
 math namespaces sequences vectors words quotations hashtables
-combinators classes classes.algebra generic.math continuations
+combinators classes classes.algebra generic.math
-optimizer.def-use optimizer.backend generic.standard
+optimizer.math.partial continuations optimizer.def-use
-optimizer.specializers optimizer.def-use optimizer.pattern-match
+optimizer.backend generic.standard optimizer.specializers
-generic.standard optimizer.control kernel.private ;
+optimizer.def-use optimizer.pattern-match generic.standard
+optimizer.control kernel.private ;
 IN: optimizer.inlining
 
 : remember-inlining ( node history -- )
@@ -53,8 +54,6 @@ DEFER: (flat-length)
     [ word-def (flat-length) ] with-scope ;
 
 ! Single dispatch method inlining optimization
-: specific-method ( class word -- class ) order min-class ;
-
 : node-class# ( node n -- class )
     over node-in-d <reversed> ?nth node-class ;
 
@@ -72,6 +71,7 @@ DEFER: (flat-length)
 ! Partial dispatch of math-generic words
 : normalize-math-class ( class -- class' )
     {
+        null
         fixnum bignum integer
         ratio rational
         float real
@@ -79,21 +79,31 @@ DEFER: (flat-length)
         object
     } [ class< ] with find nip ;
 
-: math-both-known? ( word left right -- ? )
+: inlining-math-method ( #call word -- quot/f )
-    math-class-max swap specific-method ;
+    swap node-input-classes
-
-: inline-math-method ( #call word -- node )
-    over node-input-classes
     [ first normalize-math-class ]
     [ second normalize-math-class ] bi
-    3dup math-both-known?
+    3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
-    [ math-method f splice-quot ]
+
-    [ 2drop 2drop t ] if ;
+: inline-math-method ( #call word -- node/t )
+    [ drop ] [ inlining-math-method ] 2bi
+    dup [ f splice-quot ] [ 2drop t ] if ;
+
+: inline-math-partial ( #call word -- node/t )
+    [ drop ]
+    [
+        "derived-from" word-prop first
+        inlining-math-method dup
+    ]
+    [ nip 1quotation ] 2tri
+    [ = not ] [ drop ] 2bi and
+    [ f splice-quot ] [ 2drop t ] if ;
 
 : inline-method ( #call -- node )
     dup node-param {
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
+        { [ dup math-partial? ] [ inline-math-partial ] }
         [ 2drop t ]
     } cond ;
 
@@ -183,7 +193,7 @@ DEFER: (flat-length)
     nip dup [ second ] when ;
 
 : apply-identities ( node -- node/f )
-    dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
+    dup find-identity f splice-quot ;
 
 : optimistic-inline? ( #call -- ? )
     dup node-param "specializer" word-prop dup [

core/optimizer/known-words/known-words.factor

@@ -60,7 +60,8 @@ sequences.private combinators ;
     [ value-literal sequence? ] [ drop f ] if ;
 
 : member-quot ( seq -- newquot )
-    [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
+    [ literalize [ t ] ] { } map>assoc
+    [ drop f ] suffix [ nip case ] curry ;
 
 : expand-member ( #call -- )
     dup node-in-d peek value-literal member-quot f splice-quot ;
@@ -83,21 +84,11 @@ sequences.private combinators ;
 ] "constraints" set-word-prop
 
 ! eq? on the same object is always t
-{ eq? bignum= float= number= = } {
+{ eq? = } {
     { { @ @ } [ 2drop t ] }
 } define-identities
 
 ! Specializers
-{ 1+ 1- sq neg recip sgn } [
-    { number } "specializer" set-word-prop
-] each
-
-\ 2/ { fixnum } "specializer" set-word-prop
-
-{ min max } [
-    { number number } "specializer" set-word-prop
-] each
-
 { first first2 first3 first4 }
 [ { array } "specializer" set-word-prop ] each
 

core/optimizer/math/math.factor

@@ -8,103 +8,104 @@ namespaces assocs quotations math.intervals sequences.private
 combinators splitting layouts math.parser classes
 classes.algebra generic.math optimizer.pattern-match
 optimizer.backend optimizer.def-use optimizer.inlining
-generic.standard system ;
+optimizer.math.partial generic.standard system accessors ;
 
-{ + bignum+ float+ fixnum+fast } {
+: define-math-identities ( word identities -- )
+    >r all-derived-ops r> define-identities ;
+
+\ number= {
+    { { @ @ } [ 2drop t ] }
+} define-math-identities
+
+\ + {
     { { number 0 } [ drop ] }
     { { 0 number } [ nip ] }
-} define-identities
+} define-math-identities
 
-{ fixnum+ } {
+\ - {
-    { { number 0 } [ drop ] }
-    { { 0 number } [ nip ] }
-} define-identities
-
-{ - fixnum- bignum- float- fixnum-fast } {
     { { number 0 } [ drop ] }
     { { @ @ } [ 2drop 0 ] }
-} define-identities
+} define-math-identities
 
-{ < fixnum< bignum< float< } {
+\ < {
     { { @ @ } [ 2drop f ] }
-} define-identities
+} define-math-identities
 
-{ <= fixnum<= bignum<= float<= } {
+\ <= {
     { { @ @ } [ 2drop t ] }
-} define-identities
+} define-math-identities
 
-{ > fixnum> bignum> float>= } {
+\ > {
     { { @ @ } [ 2drop f ] }
-} define-identities
+} define-math-identities
 
-{ >= fixnum>= bignum>= float>= } {
+\ >= {
     { { @ @ } [ 2drop t ] }
-} define-identities
+} define-math-identities
 
-{ * fixnum* bignum* float* } {
+\ * {
     { { number 1 } [ drop ] }
     { { 1 number } [ nip ] }
     { { number 0 } [ nip ] }
     { { 0 number } [ drop ] }
     { { number -1 } [ drop 0 swap - ] }
     { { -1 number } [ nip 0 swap - ] }
-} define-identities
+} define-math-identities
 
-{ / fixnum/i bignum/i float/f } {
+\ / {
     { { number 1 } [ drop ] }
     { { number -1 } [ drop 0 swap - ] }
-} define-identities
+} define-math-identities
 
-{ fixnum-mod bignum-mod } {
+\ mod {
-    { { number 1 } [ 2drop 0 ] }
+    { { integer 1 } [ 2drop 0 ] }
-} define-identities
+} define-math-identities
 
-{ bitand fixnum-bitand bignum-bitand } {
+\ rem {
+    { { integer 1 } [ 2drop 0 ] }
+} define-math-identities
+
+\ bitand {
     { { number -1 } [ drop ] }
     { { -1 number } [ nip ] }
     { { @ @ } [ drop ] }
     { { number 0 } [ nip ] }
     { { 0 number } [ drop ] }
-} define-identities
+} define-math-identities
 
-{ bitor fixnum-bitor bignum-bitor } {
+\ bitor {
     { { number 0 } [ drop ] }
     { { 0 number } [ nip ] }
     { { @ @ } [ drop ] }
     { { number -1 } [ nip ] }
     { { -1 number } [ drop ] }
-} define-identities
+} define-math-identities
 
-{ bitxor fixnum-bitxor bignum-bitxor } {
+\ bitxor {
     { { number 0 } [ drop ] }
     { { 0 number } [ nip ] }
     { { number -1 } [ drop bitnot ] }
     { { -1 number } [ nip bitnot ] }
     { { @ @ } [ 2drop 0 ] }
-} define-identities
+} define-math-identities
 
-{ shift fixnum-shift fixnum-shift-fast bignum-shift } {
+\ shift {
     { { 0 number } [ drop ] }
     { { number 0 } [ drop ] }
-} define-identities
+} define-math-identities
 
 : math-closure ( class -- newclass )
-    { fixnum integer rational real }
+    { null fixnum bignum integer rational float real number }
     [ class< ] with find nip number or ;
 
 : fits? ( interval class -- ? )
     "interval" word-prop dup
     [ interval-subset? ] [ 2drop t ] if ;
 
-: math-output-class ( node min -- newclass )
+: math-output-class ( node upgrades -- newclass )
-    #! if min is f, it means we just want to use the declared
+    >r
-    #! output class from the "infer-effect".
+    in-d>> null [ value-class* math-closure math-class-max ] reduce
-    dup [
+    dup r> at swap or ;
-        swap node-in-d
-        [ value-class* math-closure math-class-max ] each
-    ] [
-        2drop f
-    ] if ;
 
 : won't-overflow? ( interval node -- ? )
     node-in-d [ value-class* fixnum class< ] all?
@@ -123,28 +124,18 @@ generic.standard system ;
         2drop f
     ] if ; inline
 
-: math-output-class/interval-1 ( node min word -- classes intervals )
+: math-output-class/interval-1 ( node word -- classes intervals )
-    pick >r
+    [ drop { } math-output-class 1array ]
-    >r over r>
+    [ math-output-interval-1 1array ] 2bi ;
-    math-output-interval-1
-    >r math-output-class r>
-    r> post-process ; inline
 
 {
-    { 1+ integer interval-1+ }
+    { bitnot interval-bitnot }
-    { 1- integer interval-1- }
+    { fixnum-bitnot interval-bitnot }
-    { neg integer interval-neg }
+    { bignum-bitnot interval-bitnot }
-    { shift integer interval-recip }
-    { bitnot fixnum interval-bitnot }
-    { fixnum-bitnot f interval-bitnot }
-    { bignum-bitnot f interval-bitnot }
-    { 2/ fixnum interval-2/ }
-    { sq integer f }
 } [
-    first3 [
+    [ math-output-class/interval-1 ] curry
-        math-output-class/interval-1
+    "output-classes" set-word-prop
-    ] 2curry "output-classes" set-word-prop
+] assoc-each
-] each
 
 : intervals ( node -- i1 i2 )
     node-in-d first2 [ value-interval* ] bi@ ;
@@ -156,7 +147,7 @@ generic.standard system ;
         2drop f
     ] if ; inline
 
-: math-output-class/interval-2 ( node min word -- classes intervals )
+: math-output-class/interval-2 ( node upgrades word -- classes intervals )
     pick >r
     >r over r>
     math-output-interval-2
@@ -164,47 +155,18 @@ generic.standard system ;
     r> post-process ; inline
 
 {
-    { + integer interval+ }
+    { + { { fixnum integer } } interval+ }
-    { - integer interval- }
+    { - { { fixnum integer } } interval- }
-    { * integer interval* }
+    { * { { fixnum integer } } interval* }
-    { / rational interval/ }
+    { / { { fixnum rational } { integer rational } } interval/ }
-    { /i integer interval/i }
+    { /i { { fixnum integer } } interval/i }
-
+    { shift { { fixnum integer } } interval-shift-safe }
-    { fixnum+ f interval+ }
-    { fixnum+fast f interval+ }
-    { fixnum- f interval- }
-    { fixnum-fast f interval- }
-    { fixnum* f interval* }
-    { fixnum*fast f interval* }
-    { fixnum/i f interval/i }
-
-    { bignum+ f interval+ }
-    { bignum- f interval- }
-    { bignum* f interval* }
-    { bignum/i f interval/i }
-    { bignum-shift f interval-shift-safe }
-
-    { float+ f interval+ }
-    { float- f interval- }
-    { float* f interval* }
-    { float/f f interval/ }
-
-    { min fixnum interval-min }
-    { max fixnum interval-max }
 } [
     first3 [
+        [
             math-output-class/interval-2
         ] 2curry "output-classes" set-word-prop
-] each
+    ] 2curry each-derived-op
-
-{ fixnum-shift fixnum-shift-fast shift } [
-    [
-        dup
-        node-in-d second value-interval*
-        -1./0. 0 [a,b] interval-subset? fixnum integer ?
-        \ interval-shift-safe
-        math-output-class/interval-2
-    ] "output-classes" set-word-prop
 ] each
 
 : real-value? ( value -- n ? )
@@ -235,22 +197,18 @@ generic.standard system ;
     r> post-process ; inline
 
 {
-    { mod fixnum mod-range }
+    { mod { } mod-range }
-    { fixnum-mod f mod-range }
+    { rem { { fixnum integer } } rem-range }
-    { bignum-mod f mod-range }
-    { float-mod f mod-range }
 
-    { rem integer rem-range }
+    { bitand { } bitand-range }
-
+    { bitor { } f }
-    { bitand fixnum bitand-range }
+    { bitxor { } f }
-    { fixnum-bitand f bitand-range }
-
-    { bitor fixnum f }
-    { bitxor fixnum f }
 } [
     first3 [
+        [
             math-output-class/interval-special
         ] 2curry "output-classes" set-word-prop
+    ] 2curry each-derived-op
 ] each
 
 : twiddle-interval ( i1 -- i2 )
@@ -280,26 +238,12 @@ generic.standard system ;
     { <= assume<= assume> }
     { > assume> assume<= }
     { >= assume>= assume< }
-
-    { fixnum< assume< assume>= }
-    { fixnum<= assume<= assume> }
-    { fixnum> assume> assume<= }
-    { fixnum>= assume>= assume< }
-
-    { bignum< assume< assume>= }
-    { bignum<= assume<= assume> }
-    { bignum> assume> assume<= }
-    { bignum>= assume>= assume< }
-
-    { float< assume< assume>= }
-    { float<= assume<= assume> }
-    { float> assume> assume<= }
-    { float>= assume>= assume< }
 } [
-    first3
+    first3 [
         [
             [ comparison-constraints ] with-scope
         ] 2curry "constraints" set-word-prop
+    ] 2curry each-derived-op
 ] each
 
 {
@@ -348,22 +292,20 @@ most-negative-fixnum most-positive-fixnum [a,b]
 
 ! Removing overflow checks
 : remove-overflow-check? ( #call -- ? )
-    dup node-out-d first node-class fixnum class< ;
+    dup out-d>> first node-class
+    [ fixnum class< ] [ null eq? not ] bi and ;
 
 {
     { + [ fixnum+fast ] }
+    { +-integer-fixnum [ fixnum+fast ] }
     { - [ fixnum-fast ] }
     { * [ fixnum*fast ] }
+    { *-integer-fixnum [ fixnum*fast ] }
+    { shift [ fixnum-shift-fast ] }
     { fixnum+ [ fixnum+fast ] }
     { fixnum- [ fixnum-fast ] }
     { fixnum* [ fixnum*fast ] }
-    ! these are here as an optimization. if they weren't given
+    { fixnum-shift [ fixnum-shift-fast ] }
-    ! explicitly, the same would be inferred after an extra
-    ! optimization step (see optimistic-inline?)
-    { 1+ [ 1 fixnum+fast ] }
-    { 1- [ 1 fixnum-fast ] }
-    { 2/ [ -1 fixnum-shift ] }
-    { neg [ 0 swap fixnum-fast ] }
 } [
     [
         [ dup remove-overflow-check? ] ,
@@ -397,26 +339,13 @@ most-negative-fixnum most-positive-fixnum [a,b]
     { <= interval<= }
     { > interval> }
     { >= interval>= }
-
-    { fixnum< interval< }
-    { fixnum<= interval<= }
-    { fixnum> interval> }
-    { fixnum>= interval>= }
-
-    { bignum< interval< }
-    { bignum<= interval<= }
-    { bignum> interval> }
-    { bignum>= interval>= }
-
-    { float< interval< }
-    { float<= interval<= }
-    { float> interval> }
-    { float>= interval>= }
 } [
+    [
         [
             dup [ dupd foldable-comparison? ] curry ,
             [ fold-comparison ] curry ,
         ] { } make 1array define-optimizers
+    ] curry each-derived-op
 ] assoc-each
 
 ! The following words are handled in a similar way except if
@@ -426,44 +355,68 @@ most-negative-fixnum most-positive-fixnum [a,b]
     swap sole-consumer
     dup #call? [ node-param eq? ] [ 2drop f ] if ;
 
-: coereced-to-fixnum? ( #call -- ? )
+: coerced-to-fixnum? ( #call -- ? )
-    \ >fixnum consumed-by? ;
+    dup dup node-in-d [ node-class integer class< ] with all?
+    [ \ >fixnum consumed-by? ] [ drop f ] if ;
 
 {
-    { fixnum+ [ fixnum+fast ] }
+    { + [ [ >fixnum ] bi@ fixnum+fast ] }
-    { fixnum- [ fixnum-fast ] }
+    { - [ [ >fixnum ] bi@ fixnum-fast ] }
-    { fixnum* [ fixnum*fast ] }
+    { * [ [ >fixnum ] bi@ fixnum*fast ] }
 } [
+    >r derived-ops r> [
         [
             [
                 dup remove-overflow-check?
-            over coereced-to-fixnum? or
+                over coerced-to-fixnum? or
             ] ,
             [ f splice-quot ] curry ,
         ] { } make 1array define-optimizers
+    ] curry each
 ] assoc-each
 
-: fixnum-shift-fast-pos? ( node -- ? )
+: convert-rem-to-and? ( #call -- ? )
-    #! Shifting 1 to the left won't overflow if the shift
+    dup node-in-d {
-    #! count is small enough
+        { [ 2dup first node-class integer class< not ] [ f ] }
-    dup dup node-in-d first node-literal 1 = [
+        { [ 2dup second node-literal integer? not ] [ f ] }
-        dup node-in-d second node-interval
+        { [ 2dup second node-literal power-of-2? not ] [ f ] }
-        0 cell-bits tag-bits get - 2 - [a,b] interval-subset?
+        [ t ]
-    ] [ drop f ] if ;
+    } cond 2nip ;
 
-: fixnum-shift-fast-neg? ( node -- ? )
+: convert-mod-to-and? ( #call -- ? )
-    #! Shifting any number to the right won't overflow if the
+    dup dup node-in-d first node-interval 0 [a,inf] interval-subset?
-    #! shift count is small enough
+    [ convert-rem-to-and? ] [ drop f ] if ;
-    dup node-in-d second node-interval
-    cell-bits 1- neg 0 [a,b] interval-subset? ;
 
-: fixnum-shift-fast? ( node -- ? )
+: convert-mod-to-and ( #call -- node )
-    dup fixnum-shift-fast-pos?
+    dup
-    [ drop t ] [ fixnum-shift-fast-neg? ] if ;
+    dup node-in-d second node-literal 1-
+    [ nip bitand ] curry f splice-quot ;
 
-\ fixnum-shift {
+\ mod [
     {
-        [ dup fixnum-shift-fast? ]
+        {
-        [ [ fixnum-shift-fast ] f splice-quot ]
+            [ dup convert-mod-to-and? ]
+            [ convert-mod-to-and ]
+        }
+    } define-optimizers
+] each-derived-op
+
+\ rem {
+    {
+        [ dup convert-rem-to-and? ]
+        [ convert-mod-to-and ]
+    }
+} define-optimizers
+
+: fixnumify-bitand? ( #call -- ? )
+    dup node-in-d second node-interval fixnum fits? ;
+
+: fixnumify-bitand ( #call -- node )
+    [ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ;
+
+\ bitand {
+    {
+        [ dup fixnumify-bitand? ]
+        [ fixnumify-bitand ]
     }
 } define-optimizers

core/optimizer/math/partial/partial-tests.factor

@@ -0,0 +1,13 @@
+IN: optimizer.math.partial.tests
+USING: optimizer.math.partial tools.test math kernel
+sequences ;
+
+[ t ] [ \ + integer fixnum math-both-known? ] unit-test
+[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
+[ t ] [ \ + integer bignum math-both-known? ] unit-test
+[ t ] [ \ + float fixnum math-both-known? ] unit-test
+[ f ] [ \ + real fixnum math-both-known? ] unit-test
+[ f ] [ \ + object number math-both-known? ] unit-test
+[ f ] [ \ number= fixnum object math-both-known? ] unit-test
+[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
+[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test

core/optimizer/math/partial/partial.factor

@@ -0,0 +1,172 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel kernel.private math math.private words
+sequences parser namespaces assocs quotations arrays
+generic generic.math hashtables effects ;
+IN: optimizer.math.partial
+
+! Partial dispatch.
+
+! This code will be overhauled and generalized when
+! multi-methods go into the core.
+PREDICATE: math-partial < word
+    "derived-from" word-prop >boolean ;
+
+: fixnum-integer-op ( a b fix-word big-word -- c )
+    pick tag 0 eq? [
+        drop execute
+    ] [
+        >r drop >r fixnum>bignum r> r> execute
+    ] if ; inline
+
+: integer-fixnum-op ( a b fix-word big-word -- c )
+    >r pick tag 0 eq? [
+        r> drop execute
+    ] [
+        drop fixnum>bignum r> execute
+    ] if ; inline
+
+: integer-integer-op ( a b fix-word big-word -- c )
+    pick tag 0 eq? [
+        integer-fixnum-op
+    ] [
+        >r drop over tag 0 eq? [
+            >r fixnum>bignum r> r> execute
+        ] [
+            r> execute
+        ] if
+    ] if ; inline
+
+<<
+: integer-op-combinator ( triple -- word )
+    [
+        [ second word-name % "-" % ]
+        [ third word-name % "-op" % ]
+        bi
+    ] "" make in get lookup ;
+
+: integer-op-word ( triple fix-word big-word -- word )
+    [
+        drop
+        word-name "fast" tail? >r
+        [ "-" % ] [ word-name % ] interleave
+        r> [ "-fast" % ] when
+    ] "" make in get create ;
+
+: integer-op-quot ( word fix-word big-word -- quot )
+    rot integer-op-combinator 1quotation 2curry ;
+
+: define-integer-op-word ( word fix-word big-word -- )
+    [
+        [ integer-op-word ] [ integer-op-quot ] 3bi
+        2 1 <effect> define-declared
+    ]
+    [
+        [ integer-op-word ] [ 2drop ] 3bi
+        "derived-from" set-word-prop
+    ] 3bi ;
+
+: define-integer-op-words ( words fix-word big-word -- )
+    [ define-integer-op-word ] 2curry each ;
+
+: integer-op-triples ( word -- triples )
+    {
+        { fixnum integer }
+        { integer fixnum }
+        { integer integer }
+    } swap [ prefix ] curry map ;
+
+: define-integer-ops ( word fix-word big-word -- )
+    >r >r integer-op-triples r> r>
+    [ define-integer-op-words ]
+    [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
+    3bi ;
+
+: define-math-ops ( op -- )
+    { fixnum bignum float }
+    [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
+    [ nip ] assoc-subset
+    [ word-def peek ] assoc-map % ;
+
+SYMBOL: math-ops
+
+[
+    \ +       define-math-ops
+    \ -       define-math-ops
+    \ *       define-math-ops
+    \ shift   define-math-ops
+    \ mod     define-math-ops
+    \ /i      define-math-ops
+
+    \ bitand  define-math-ops
+    \ bitor   define-math-ops
+    \ bitxor  define-math-ops
+
+    \ <       define-math-ops
+    \ <=      define-math-ops
+    \ >       define-math-ops
+    \ >=      define-math-ops
+    \ number= define-math-ops
+
+    \ + \ fixnum+ \ bignum+ define-integer-ops
+    \ - \ fixnum- \ bignum- define-integer-ops
+    \ * \ fixnum* \ bignum* define-integer-ops
+    \ shift \ fixnum-shift \ bignum-shift define-integer-ops
+    \ mod \ fixnum-mod \ bignum-mod define-integer-ops
+    \ /i \ fixnum/i \ bignum/i define-integer-ops
+    
+    \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
+    \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
+    \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
+    
+    \ < \ fixnum< \ bignum< define-integer-ops
+    \ <= \ fixnum<= \ bignum<= define-integer-ops
+    \ > \ fixnum> \ bignum> define-integer-ops
+    \ >= \ fixnum>= \ bignum>= define-integer-ops
+    \ number= \ eq? \ bignum= define-integer-ops
+] { } make >hashtable math-ops set-global
+
+SYMBOL: fast-math-ops
+
+[
+    { { + fixnum fixnum } fixnum+fast } ,
+    { { - fixnum fixnum } fixnum-fast } ,
+    { { * fixnum fixnum } fixnum*fast } ,
+    { { shift fixnum fixnum } fixnum-shift-fast } ,
+
+    \ + \ fixnum+fast \ bignum+ define-integer-ops
+    \ - \ fixnum-fast \ bignum- define-integer-ops
+    \ * \ fixnum*fast \ bignum* define-integer-ops
+    \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
+] { } make >hashtable fast-math-ops set-global
+
+>>
+
+: math-op ( word left right -- word' ? )
+    3array math-ops get at* ;
+
+: math-method* ( word left right -- quot )
+    3dup math-op
+    [ >r 3drop r> 1quotation ] [ drop math-method ] if ;
+
+: math-both-known? ( word left right -- ? )
+    3dup math-op
+    [ 2drop 2drop t ]
+    [ drop math-class-max swap specific-method >boolean ] if ;
+
+: (derived-ops) ( word assoc -- words )
+    swap [ rot first eq? nip ] curry assoc-subset values ;
+
+: derived-ops ( word -- words )
+    [ 1array ]
+    [ math-ops get (derived-ops) ]
+    bi append ;
+
+: fast-derived-ops ( word -- words )
+    fast-math-ops get (derived-ops) ;
+
+: all-derived-ops ( word -- words )
+    [ derived-ops ] [ fast-derived-ops ] bi append ;
+
+: each-derived-op ( word quot -- )
+    >r derived-ops r> each ; inline

core/optimizer/optimizer-tests.factor

@@ -1,9 +1,9 @@
 USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer prettyprint sequences sbufs
+kernel.private math optimizer generator prettyprint sequences
-strings tools.test vectors words sequences.private quotations
+sbufs strings tools.test vectors words sequences.private
-optimizer.backend classes classes.algebra inference.dataflow
+quotations optimizer.backend classes classes.algebra
-classes.tuple.private continuations growable optimizer.inlining
+inference.dataflow classes.tuple.private continuations growable
-namespaces hints ;
+optimizer.inlining namespaces hints ;
 IN: optimizer.tests
 
 [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@@ -14,40 +14,6 @@ IN: optimizer.tests
     H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
 ] unit-test
 
-! Test method inlining
-[ f ] [ fixnum { } min-class ] unit-test
-
-[ string ] [
-    \ string
-    [ integer string array reversed sbuf
-    slice vector quotation ]
-    sort-classes min-class
-] unit-test
-
-[ fixnum ] [
-    \ fixnum
-    [ fixnum integer object ]
-    sort-classes min-class
-] unit-test
-
-[ integer ] [
-    \ fixnum
-    [ integer float object ]
-    sort-classes min-class
-] unit-test
-
-[ object ] [
-    \ word
-    [ integer float object ]
-    sort-classes min-class
-] unit-test
-
-[ reversed ] [
-    \ reversed
-    [ integer reversed slice ]
-    sort-classes min-class
-] unit-test
-
 GENERIC: xyz ( obj -- obj )
 M: array xyz xyz ;
 
@@ -325,7 +291,6 @@ TUPLE: silly-tuple a b ;
 
 [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
 
-! Make sure we don't lose
 GENERIC: generic-inline-test ( x -- y )
 M: integer generic-inline-test ;
 
@@ -342,6 +307,7 @@ M: integer generic-inline-test ;
     generic-inline-test
     generic-inline-test ;
 
+! Inlining all of the above should only take two passes
 [ { t f } ] [
     \ generic-inline-test-1 word-def dataflow
     [ optimize-1 , optimize-1 , drop ] { } make
@@ -374,3 +340,19 @@ HINTS: recursive-inline-hang-3 array ;
 USE: sequences.private
 
 [ ] [ { (3append) } compile ] unit-test
+
+! Wow
+: counter-example ( a b c d -- a' b' c' d' )
+    dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
+
+: counter-example' ( -- a' b' c' d' )
+    1 2 3.0 3 counter-example ;
+
+[ 2 4 6.0 0 ] [ counter-example' ] unit-test
+
+: member-test { + - * / /i } member? ;
+
+\ member-test must-infer
+[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
+[ t ] [ \ + member-test ] unit-test
+[ f ] [ \ append member-test ] unit-test

core/optimizer/optimizer.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces optimizer.backend optimizer.def-use
 optimizer.known-words optimizer.math optimizer.control
-optimizer.inlining inference.class ;
+optimizer.collect optimizer.inlining inference.class ;
 IN: optimizer
 
 : optimize-1 ( node -- newnode ? )
@@ -10,10 +10,13 @@ IN: optimizer
         H{ } clone class-substitutions set
         H{ } clone literal-substitutions set
         H{ } clone value-substitutions set
-        dup compute-def-use
+
+        collect-label-infos
+        compute-def-use
         kill-values
-        dup detect-loops
+        detect-loops
-        dup infer-classes
+        infer-classes
+
         optimizer-changed off
         optimize-nodes
         optimizer-changed get

core/prettyprint/backend/backend.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
+USING: arrays byte-arrays bit-arrays generic hashtables io
-generic hashtables io assocs kernel math namespaces sequences
+assocs kernel math namespaces sequences strings sbufs io.styles
-strings sbufs io.styles vectors words prettyprint.config
+vectors words prettyprint.config prettyprint.sections quotations
-prettyprint.sections quotations io io.files math.parser effects
+io io.files math.parser effects classes.tuple
-classes.tuple classes.tuple.private classes float-arrays
+classes.tuple.private classes float-arrays ;
-float-vectors ;
 IN: prettyprint.backend
 
 GENERIC: pprint* ( obj -- )
@@ -140,11 +139,8 @@ M: curry pprint-delims drop \ [ \ ] ;
 M: compose pprint-delims drop \ [ \ ] ;
 M: array pprint-delims drop \ { \ } ;
 M: byte-array pprint-delims drop \ B{ \ } ;
-M: byte-vector pprint-delims drop \ BV{ \ } ;
 M: bit-array pprint-delims drop \ ?{ \ } ;
-M: bit-vector pprint-delims drop \ ?V{ \ } ;
 M: float-array pprint-delims drop \ F{ \ } ;
-M: float-vector pprint-delims drop \ FV{ \ } ;
 M: vector pprint-delims drop \ V{ \ } ;
 M: hashtable pprint-delims drop \ H{ \ } ;
 M: tuple pprint-delims drop \ T{ \ } ;
@@ -156,9 +152,6 @@ GENERIC: >pprint-sequence ( obj -- seq )
 M: object >pprint-sequence ;
 
 M: vector >pprint-sequence ;
-M: bit-vector >pprint-sequence ;
-M: byte-vector >pprint-sequence ;
-M: float-vector >pprint-sequence ;
 M: curry >pprint-sequence ;
 M: compose >pprint-sequence ;
 M: hashtable >pprint-sequence >alist ;

core/prettyprint/config/config.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: prettyprint.config
-USING: alien arrays generic assocs io kernel math
+USING: arrays generic assocs io kernel math
 namespaces sequences strings io.styles vectors words
 continuations ;
 

core/prettyprint/prettyprint.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: prettyprint
-USING: alien arrays generic generic.standard assocs io kernel
+USING: arrays generic generic.standard assocs io kernel
 math namespaces sequences strings io.styles io.streams.string
 vectors words prettyprint.backend prettyprint.sections
 prettyprint.config sorting splitting math.parser vocabs

core/prettyprint/sections/sections.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays generic hashtables io kernel math assocs
+USING: arrays generic hashtables io kernel math assocs
 namespaces sequences strings io.styles vectors words
 prettyprint.config splitting classes continuations
 io.streams.nested accessors ;

core/sequences/sequences-docs.factor

@@ -76,10 +76,7 @@ ARTICLE: "sequences-reshape" "Reshaping sequences"
 { $subsection reversed }
 { $subsection <reversed> }
 "Transposing a matrix:"
-{ $subsection flip }
+{ $subsection flip } ;
-"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
-{ $subsection column }
-{ $subsection <column> } ;
 
 ARTICLE: "sequences-appending" "Appending sequences"
 { $subsection append }
@@ -785,23 +782,6 @@ HELP: <slice>
 
 { <slice> subseq } related-words
 
-HELP: column
-{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
-
-HELP: <column> ( seq n -- column )
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
-{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
-{ $examples
-    { $example
-        "USING: arrays prettyprint sequences ;"
-        "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
-        "{ 1 4 7 }"
-    }
-}
-{ $notes
-    "In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
-} ;
-
 HELP: repetition
 { $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
 

core/sequences/sequences-tests.factor

@@ -224,13 +224,6 @@ unit-test
 [ V{ 1 2 3 } ]
 [ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
 
-! Columns
-{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
-
-[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
-[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
-[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
-
 ! erg's random tester found this one
 [ SBUF" 12341234" ] [
     9 <sbuf> dup "1234" swap push-all dup dup swap push-all

core/sequences/sequences.factor

@@ -215,18 +215,6 @@ M: slice length dup slice-to swap slice-from - ;
 
 INSTANCE: slice virtual-sequence
 
-! A column of a matrix
-TUPLE: column seq col ;
-
-C: <column> column
-
-M: column virtual-seq column-seq ;
-M: column virtual@
-    dup column-col -rot column-seq nth bounds-check ;
-M: column length column-seq length ;
-
-INSTANCE: column virtual-sequence
-
 ! One element repeated many times
 TUPLE: repetition len elt ;
 
@@ -703,5 +691,5 @@ PRIVATE>
 : flip ( matrix -- newmatrix )
     dup empty? [
         dup [ length ] map infimum
-        [ <column> dup like ] with map
+        swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
     ] unless ;

core/syntax/syntax-docs.factor

@@ -150,18 +150,6 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax"
 { $subsection POSTPONE: B{ }
 "Byte arrays are documented in " { $link "byte-arrays" } "." ;
 
-ARTICLE: "syntax-bit-vectors" "Bit vector syntax"
-{ $subsection POSTPONE: ?V{ }
-"Bit vectors are documented in " { $link "bit-vectors" } "." ;
-
-ARTICLE: "syntax-float-vectors" "Float vector syntax"
-{ $subsection POSTPONE: FV{ }
-"Float vectors are documented in " { $link "float-vectors" } "." ;
-
-ARTICLE: "syntax-byte-vectors" "Byte vector syntax"
-{ $subsection POSTPONE: BV{ }
-"Byte vectors are documented in " { $link "byte-vectors" } "." ;
-
 ARTICLE: "syntax-pathnames" "Pathname syntax"
 { $subsection POSTPONE: P" }
 "Pathnames are documented in " { $link "pathnames" } "." ;
@@ -182,9 +170,6 @@ $nl
 { $subsection "syntax-float-arrays" }
 { $subsection "syntax-vectors" }
 { $subsection "syntax-sbufs" }
-{ $subsection "syntax-bit-vectors" }
-{ $subsection "syntax-byte-vectors" }
-{ $subsection "syntax-float-vectors" }
 { $subsection "syntax-hashtables" }
 { $subsection "syntax-tuples" }
 { $subsection "syntax-pathnames" } ;
@@ -291,30 +276,12 @@ HELP: B{
 { $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." } 
 { $examples { $code "B{ 1 2 3 }" } } ;
 
-HELP: BV{
-{ $syntax "BV{ elements... }" }
-{ $values { "elements" "a list of bytes" } }
-{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } 
-{ $examples { $code "BV{ 1 2 3 12 }" } } ;
-
 HELP: ?{
 { $syntax "?{ elements... }" }
 { $values { "elements" "a list of booleans" } }
 { $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } 
 { $examples { $code "?{ t f t }" } } ;
 
-HELP: ?V{
-{ $syntax "?V{ elements... }" }
-{ $values { "elements" "a list of booleans" } }
-{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } 
-{ $examples { $code "?V{ t f t }" } } ;
-
-HELP: FV{
-{ $syntax "FV{ elements... }" }
-{ $values { "elements" "a list of real numbers" } }
-{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } 
-{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;
-
 HELP: F{
 { $syntax "F{ elements... }" }
 { $values { "elements" "a list of real numbers" } }

core/syntax/syntax.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays bit-vectors byte-arrays
+USING: alien arrays bit-arrays byte-arrays
-byte-vectors definitions generic hashtables kernel math
+definitions generic hashtables kernel math
 namespaces parser sequences strings sbufs vectors words
 quotations io assocs splitting classes.tuple generic.standard
-generic.math classes io.files vocabs float-arrays float-vectors
+generic.math classes io.files vocabs float-arrays
 classes.union classes.mixin classes.predicate classes.singleton
 compiler.units combinators debugger ;
 IN: bootstrap.syntax
@@ -79,11 +79,8 @@ IN: bootstrap.syntax
     "{" [ \ } [ >array ] parse-literal ] define-syntax
     "V{" [ \ } [ >vector ] parse-literal ] define-syntax
     "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
-    "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
     "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
-    "?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax
     "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
-    "FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax
     "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
     "T{" [ \ } [ >tuple ] parse-literal ] define-syntax
     "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax

core/threads/threads-docs.factor

@@ -26,7 +26,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
 { $subsection resume }
 { $subsection resume-with } ;
 
-ARTICLE: "thread-state" "Thread-local state"
+ARTICLE: "thread-state" "Thread-local state and variables"
 "Threads form a class of objects:"
 { $subsection thread }
 "The current thread:"
@@ -36,6 +36,8 @@ ARTICLE: "thread-state" "Thread-local state"
 { $subsection tget }
 { $subsection tset }
 { $subsection tchange }
+"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
+$nl
 "Global hashtable of all threads, keyed by " { $link thread-id } ":"
 { $subsection threads }
 "Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;

core/threads/threads-tests.factor

@@ -1,4 +1,5 @@
-USING: namespaces io tools.test threads kernel ;
+USING: namespaces io tools.test threads kernel
+concurrency.combinators math ;
 IN: threads.tests
 
 3 "x" set
@@ -16,3 +17,13 @@ yield
 ] unit-test
 
 [ f ] [ f get-global ] unit-test
+
+{ { 0 3 6 9 12 15 18 21 24 27 } } [
+    10 [
+        0 "i" tset
+        [
+            "i" [ yield 3 + ] tchange
+        ] times yield
+        "i" tget
+    ] parallel-map
+] unit-test

core/threads/threads.factor

@@ -27,7 +27,7 @@ mailbox variables sleep-entry ;
     tnamespace set-at ;
 
 : tchange ( key quot -- )
-    tnamespace change-at ; inline
+    tnamespace swap change-at ; inline
 
 : threads 41 getenv ;
 

extra/benchmark/binary-trees/binary-trees.factor

@@ -0,0 +1,55 @@
+USING: kernel math accessors prettyprint io locals sequences
+math.ranges ;
+IN: benchmark.binary-trees
+
+TUPLE: tree-node item left right ;
+
+C: <tree-node> tree-node
+
+: bottom-up-tree ( item depth -- tree )
+    dup 0 > [
+        1 -
+        [ drop ]
+        [ >r 2 * 1 - r> bottom-up-tree ]
+        [ >r 2 *     r> bottom-up-tree ] 2tri
+    ] [
+        drop f f
+    ] if <tree-node> ;
+
+GENERIC: item-check ( node -- n )
+
+M: tree-node item-check
+    [ item>> ] [ left>> ] [ right>> ] tri [ item-check ] bi@ - + ;
+
+M: f item-check drop 0 ;
+
+: min-depth 4 ; inline
+
+: stretch-tree ( max-depth -- )
+    1 + 0 over bottom-up-tree item-check
+    [ "stretch tree of depth " write pprint ]
+    [ "\t check: " write . ] bi* ;
+
+:: long-lived-tree ( max-depth -- )
+    0 max-depth bottom-up-tree
+
+    min-depth max-depth 2 <range> [| depth |
+        max-depth depth - min-depth + 2^ [
+            [1,b] 0 [
+                dup neg
+                [ depth bottom-up-tree item-check + ] bi@
+            ] reduce
+        ]
+        [ 2 * ] bi
+        pprint "\t trees of depth " write depth pprint
+        "\t check: " write .
+    ] each
+
+    "long lived tree of depth " write max-depth pprint
+    "\t check: " write item-check . ;
+
+: binary-trees ( n -- )
+    min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ;
+
+: binary-trees-main ( -- )
+    16 binary-trees ;

extra/benchmark/dispatch2/dispatch2.factor

@@ -1,4 +1,4 @@
-USING: namespaces math sequences splitting kernel ;
+USING: namespaces math sequences splitting kernel columns ;
 IN: benchmark.dispatch2
 
 : sequences

extra/benchmark/dispatch3/dispatch3.factor

@@ -1,5 +1,5 @@
 USING: sequences math mirrors splitting kernel namespaces
-assocs alien.syntax ;
+assocs alien.syntax columns ;
 IN: benchmark.dispatch3
 
 GENERIC: g ( obj -- str )

extra/benchmark/recursive/recursive.factor

@@ -1,38 +1,37 @@
+USING: math kernel hints prettyprint io combinators ;
 IN: benchmark.recursive
-USING: math kernel hints prettyprint io ;
 
 : fib ( m -- n )
-    dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
+    dup 2 < [ drop 1 ] [ [ 1 - fib ] [ 2 - fib ] bi + ] if ;
+    inline
 
 : ack ( m n -- x )
-    over zero? [
+    {
-        nip 1+
+        { [ over zero? ] [ nip 1+ ] }
-    ] [
+        { [ dup zero? ] [ drop 1- 1 ack ] }
-        dup zero? [
+        [ [ drop 1- ] [ 1- ack ] 2bi ack ]
-            drop 1- 1 ack
+    } cond ; inline
-        ] [
-            dupd 1- ack >r 1- r> ack
-        ] if
-    ] if ;
 
 : tak ( x y z -- t )
-    2over swap < [
+    2over <= [
-        [ rot 1- -rot tak ] 3keep
-        [ -rot 1- -rot tak ] 3keep
-        1- -rot tak
-        tak
-    ] [
         2nip
-    ] if ;
+    ] [
+        [  rot 1- -rot tak ]
+        [ -rot 1- -rot tak ]
+        [      1- -rot tak ]
+        3tri
+        tak
+    ] if ; inline
 
 : recursive ( n -- )
-    3 over ack . flush
+    [ 3 swap ack . flush ]
-    dup 27.0 + fib . flush
+    [ 27.0 + fib . flush ]
-    1-
+    [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
-    dup 3 * over 2 * rot tak . flush
     3 fib . flush
     3.0 2.0 1.0 tak . flush ;
 
+HINTS: recursive fixnum ;
+
 : recursive-main 11 recursive ;
 
 MAIN: recursive-main

extra/benchmark/spectral-norm/spectral-norm.factor

@@ -1,48 +1,44 @@
 ! Factor port of
 ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
 USING: float-arrays kernel math math.functions math.vectors
-sequences sequences.private prettyprint words tools.time hints ;
+sequences sequences.private prettyprint words
+hints locals ;
 IN: benchmark.spectral-norm
 
-: fast-truncate >fixnum >float ; inline
+:: inner-loop ( u n quot -- seq )
+    n [| i |
+        n 0.0 [| j |
+            u i j quot call +
+        ] reduce
+    ] F{ } map-as ; inline
 
 : eval-A ( i j -- n )
     [ >float ] bi@
-    dupd + dup 1+ * 2 /f fast-truncate + 1+
+    [ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi
-    recip ; inline
+    + 1 + recip ; inline
 
 : (eval-A-times-u) ( u i j -- x )
-    tuck eval-A >r swap nth-unsafe r> * ; inline
+    tuck [ swap nth-unsafe ] [ eval-A ] 2bi* * ; inline
 
 : eval-A-times-u ( n u -- seq )
-    over [
+    [ (eval-A-times-u) ] inner-loop ; inline
-        pick 0.0 [
-            swap >r >r 2dup r> (eval-A-times-u) r> +
-        ] reduce nip
-    ] F{ } map-as 2nip ; inline
 
 : (eval-At-times-u) ( u i j -- x )
-    tuck swap eval-A >r swap nth-unsafe r> * ; inline
+    tuck [ swap nth-unsafe ] [ swap eval-A ] 2bi* * ; inline
 
-: eval-At-times-u ( n u -- seq )
+: eval-At-times-u ( u n -- seq )
-    over [
+    [ (eval-At-times-u) ] inner-loop ; inline
-        pick 0.0 [
-            swap >r >r 2dup r> (eval-At-times-u) r> +
-        ] reduce nip
-    ] F{ } map-as 2nip ; inline
 
-: eval-AtA-times-u ( n u -- seq )
+: eval-AtA-times-u ( u n -- seq )
-    dupd eval-A-times-u eval-At-times-u ; inline
+    [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
 
-: u/v ( n -- u v )
+:: u/v ( n -- u v )
-    dup 1.0 <float-array> dup
+    n 1.0 <float-array> dup
     10 [
         drop
-        dupd eval-AtA-times-u
+        n eval-AtA-times-u
-        2dup eval-AtA-times-u
+        [ n eval-AtA-times-u ] keep
-        swap
+    ] times ; inline
-    ] times
-    rot drop ; inline
 
 : spectral-norm ( n -- norm )
     u/v [ v. ] keep norm-sq /f sqrt ;
@@ -50,6 +46,6 @@ IN: benchmark.spectral-norm
 HINTS: spectral-norm fixnum ;
 
 : spectral-norm-main ( -- )
-    2000 spectral-norm . ;
+    5500 spectral-norm . ;
 
 MAIN: spectral-norm-main

extra/bit-vectors/bit-vectors-docs.factor

@@ -3,7 +3,7 @@ bit-vectors.private combinators ;
 IN: bit-vectors
 
 ARTICLE: "bit-vectors" "Bit vectors"
-"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
+"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
 $nl
 "Bit vectors form a class:"
 { $subsection bit-vector }
@@ -11,13 +11,15 @@ $nl
 "Creating bit vectors:"
 { $subsection >bit-vector }
 { $subsection <bit-vector> }
+"Literal syntax:"
+{ $subsection POSTPONE: ?V{ }
 "If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
 { $code "?V{ } clone" } ;
 
 ABOUT: "bit-vectors"
 
 HELP: bit-vector
-{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
+{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
 
 HELP: <bit-vector>
 { $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
@@ -31,3 +33,10 @@ HELP: bit-array>vector
 { $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }
 { $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }
 { $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;
+
+HELP: ?V{
+{ $syntax "?V{ elements... }" }
+{ $values { "elements" "a list of booleans" } }
+{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } 
+{ $examples { $code "?V{ t f t }" } } ;
+

extra/bit-vectors/bit-vectors.factor

@@ -1,9 +1,20 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable bit-arrays ;
+sequences.private growable bit-arrays prettyprint.backend
+parser accessors ;
 IN: bit-vectors
 
+TUPLE: bit-vector underlying fill ;
+
+M: bit-vector underlying underlying>> { bit-array } declare ;
+
+M: bit-vector set-underlying (>>underlying) ;
+
+M: bit-vector length fill>> { array-capacity } declare ;
+
+M: bit-vector set-fill (>>fill) ;
+
 <PRIVATE
 
 : bit-array>vector ( bit-array length -- bit-vector )
@@ -14,7 +25,8 @@ PRIVATE>
 : <bit-vector> ( n -- bit-vector )
     <bit-array> 0 bit-array>vector ; inline
 
-: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ;
+: >bit-vector ( seq -- bit-vector )
+    T{ bit-vector f ?{ } 0 } clone-like ;
 
 M: bit-vector like
     drop dup bit-vector? [
@@ -31,3 +43,9 @@ M: bit-vector equal?
 M: bit-array new-resizable drop <bit-vector> ;
 
 INSTANCE: bit-vector growable
+
+: ?V{ \ } [ >bit-vector ] parse-literal ; parsing
+
+M: bit-vector >pprint-sequence ;
+
+M: bit-vector pprint-delims drop \ ?V{ \ } ;