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

core/bootstrap/compiler/compiler.factor

@@ -74,6 +74,12 @@ nl
     malloc free memcpy
 } compile
 
-[ compiled-usages recompile ] recompile-hook set-global
+: enable-compiler ( -- )
+    [ compiled-usages recompile ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+    [ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ;
+
+enable-compiler
 
 " done" print flush

core/combinators/combinators-docs.factor

@@ -7,11 +7,7 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
 "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
 { $subsection cond>quot }
 { $subsection case>quot }
-{ $subsection alist>quot }
+{ $subsection alist>quot } ;
-"A powerful tool used to optimize code in several places is open-coded hashtable dispatch:"
-{ $subsection hash-case>quot }
-{ $subsection distribute-buckets }
-{ $subsection hash-dispatch-quot } ;
 
 ARTICLE: "combinators" "Additional combinators"
 "The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":"
@@ -104,19 +100,17 @@ HELP: case>quot
 { $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } }
 { $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
 $nl
-"The quotation actually tests each possible case in order;" { $link hash-case>quot } " produces more efficient code." } ;
+"This word uses three strategies:"
+{ $list
+    "If the assoc only has a few keys, a linear search is generated."
+    { "If the assoc has a large number of keys which form a contiguous range of integers, a direct dispatch is generated using the " { $link dispatch } " word together with a bounds check." }
+    "Otherwise, an open-coded hashtable dispatch is generated."
+} } ;
 
 HELP: distribute-buckets
 { $values { "assoc" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } }
 { $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." }
-{ $notes "This word is used in the implemention of " { $link hash-case>quot } " and " { $link standard-combination } "." } ;
+{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
-
-HELP: hash-case>quot
-{ $values { "default" quotation } { "assoc" "an association list mapping quotations to quotations" } { "quot" quotation } }
-{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
-$nl
-"The quotation uses an efficient hash-based search to avoid testing the object against all possible keys." }
-{ $notes "This word is used behind the scenes to compile " { $link case } " forms efficiently; it can also be called directly,  which is useful for meta-programming." } ;
 
 HELP: dispatch ( n array -- )
 { $values { "n" "a fixnum" } { "array" "an array of quotations" } }

core/combinators/combinators-tests.factor

@@ -69,3 +69,10 @@ namespaces combinators words ;
 
 ! Interpreted
 [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
+
+[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
+[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
+[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
+[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
+[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
+[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test

core/combinators/combinators.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: combinators
 USING: arrays sequences sequences.private math.private
-kernel kernel.private math assocs quotations vectors ;
+kernel kernel.private math assocs quotations vectors
+hashtables sorting ;
 
 TUPLE: no-cond ;
 
@@ -31,16 +32,24 @@ TUPLE: no-case ;
 : recursive-hashcode ( n obj quot -- code )
     pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
 
+! These go here, not in sequences and hashtables, since those
+! two depend on combinators
 M: sequence hashcode*
     [ sequence-hashcode ] recursive-hashcode ;
 
+M: hashtable hashcode*
+    [
+        dup assoc-size 1 number=
+        [ assoc-hashcode ] [ nip assoc-size ] if
+    ] recursive-hashcode ;
+
 : alist>quot ( default assoc -- quot )
     [ rot \ if 3array append [ ] like ] assoc-each ;
 
 : cond>quot ( assoc -- quot )
     reverse [ no-cond ] swap alist>quot ;
 
-: case>quot ( default assoc -- quot )
+: linear-case-quot ( default assoc -- quot )
     [ >r [ dupd = ] curry r> \ drop add* ] assoc-map
     alist>quot ;
 
@@ -63,20 +72,50 @@ M: sequence hashcode*
 
 : hash-case-table ( default assoc -- array )
     V{ } [ 1array ] distribute-buckets
-    [ case>quot ] with map ;
+    [ linear-case-quot ] with map ;
 
 : hash-dispatch-quot ( table -- quot )
     [ length 1- [ fixnum-bitand ] curry ] keep
     [ dispatch ] curry append ;
 
-: hash-case>quot ( default assoc -- quot )
+: hash-case-quot ( default assoc -- quot )
+    hash-case-table hash-dispatch-quot
+    [ dup hashcode >fixnum ] swap append ;
+
+: contiguous-range? ( keys -- from to ? )
+    dup [ fixnum? ] all? [
+        dup all-unique? [
+            dup infimum over supremum
+            [ - swap prune length + 1 = ] 2keep rot
+        ] [
+            drop f f f
+        ] if
+    ] [
+        drop f f f
+    ] if ;
+
+: dispatch-case ( value from to default array -- )
+    >r >r 3dup between? [
+        drop - >fixnum r> drop r> dispatch
+    ] [
+        2drop r> call r> drop
+    ] if ; inline
+
+: dispatch-case-quot ( default assoc from to -- quot )
+    -roll -roll sort-keys values [ >quotation ] map
+    [ dispatch-case ] 2curry 2curry ;
+
+: case>quot ( default assoc -- quot )
     dup empty? [
         drop
     ] [
         dup length 4 <= [
-            case>quot
+            linear-case-quot
         ] [
-            hash-case-table hash-dispatch-quot
+            dup keys contiguous-range? [
-            [ dup hashcode >fixnum ] swap append
+                dispatch-case-quot
+            ] [
+                2drop hash-case-quot
+            ] if
         ] if
     ] if ;

core/compiler/tests/stack-trace.factor

@@ -1,7 +1,7 @@
 IN: temporary
 USING: compiler tools.test namespaces sequences
 kernel.private kernel math continuations continuations.private
-words splitting ;
+words splitting sorting ;
 
 : symbolic-stack-trace ( -- newseq )
     error-continuation get continuation-call callstack>array
@@ -31,9 +31,9 @@ words splitting ;
     \ > stack-trace-contains?
 ] unit-test
 
-: quux [ t [ "hi" throw ] when ] times ;
+: quux { 1 2 3 } [ "hi" throw ] sort ;
 
 [ t ] [
     [ 10 quux ] ignore-errors
-    \ (each-integer) stack-trace-contains?
+    \ sort stack-trace-contains?
 ] unit-test

core/compiler/tests/templates-early.factor

@@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ;
 [
     [ ] [ init-templates ] unit-test
 
-    [ ] [ init-generator ] unit-test
+    H{ } clone compiled set
+
+    [ ] [ gensym gensym begin-compiling ] unit-test
 
     [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
 

core/hashtables/hashtables.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private slots.private math assocs
-math.private sequences sequences.private vectors
+math.private sequences sequences.private vectors ;
-combinators ;
 IN: hashtables
 
 <PRIVATE
@@ -161,17 +160,10 @@ M: hashtable clone
     (clone) dup hash-array clone over set-hash-array ;
 
 M: hashtable equal?
-    {
+    over hashtable? [
-        { [ over hashtable? not ] [ 2drop f ] }
+        2dup [ assoc-size ] 2apply number=
-        { [ 2dup [ assoc-size ] 2apply number= not ] [ 2drop f ] }
+        [ assoc= ] [ 2drop f ] if
-        { [ t ] [ assoc= ] }
+    ] [ 2drop f ] if ;
-    } cond ;
-
-M: hashtable hashcode*
-    [
-        dup assoc-size 1 number=
-        [ assoc-hashcode ] [ nip assoc-size ] if
-    ] recursive-hashcode ;
 
 ! Default method
 M: assoc new-assoc drop <hashtable> ;

core/inference/dataflow/dataflow.factor

@@ -314,7 +314,7 @@ PREDICATE: #merge #tail-merge node-successor #tail? ;
 PREDICATE: #values #tail-values node-successor #tail? ;
 
 UNION: #tail
-    POSTPONE: f #return #tail-values #tail-merge ;
+    POSTPONE: f #return #tail-values #tail-merge #terminate ;
 
 : tail-call? ( -- ? )
     node-stack get [ node-successor #tail? ] all? ;

core/inference/transforms/transforms.factor

@@ -35,7 +35,7 @@ IN: inference.transforms
             dup peek swap 1 head*
         ] [
             [ no-case ] swap
-        ] if hash-case>quot
+        ] if case>quot
     ] if
 ] 1 define-transform
 

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

@@ -0,0 +1,5 @@
+USING: help.syntax help.markup ;
+IN: io.encodings.binary
+
+HELP: binary
+{ $class-description "This is the encoding descriptor for binary I/O." } ;

core/io/encodings/binary/binary.factor

@@ -0,0 +1,6 @@
+USING: kernel io.encodings ;
+
+TUPLE: binary ;
+
+M: binary init-decoding drop ;
+M: binary init-encoding drop ;

core/io/encodings/binary/summary.txt

@@ -0,0 +1 @@
+Dummy encoding for binary I/O

core/io/encodings/binary/tags.txt

@@ -0,0 +1 @@
+text

core/io/encodings/encodings.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2006, 2007 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors
+USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
-namespaces unicode.syntax ;
+namespaces unicode.syntax growable strings io classes io.streams.c
+continuations ;
 IN: io.encodings
 
 TUPLE: encode-error ;
@@ -23,6 +24,72 @@ SYMBOL: begin
 : finish-decoding ( buf ch state -- str )
     begin eq? [ decode-error ] unless drop "" like ;
 
-: decode ( seq quot -- str )
+: start-decoding ( seq length -- buf ch state seq )
-    >r [ length <sbuf> 0 begin ] keep r> each
+    <sbuf> 0 begin roll ;
+
+GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
+
+: decode ( seq quot -- string )
+    >r dup length start-decoding r>
+    [ -rot ] swap compose each
     finish-decoding ; inline
+
+: space ( resizable -- room-left )
+    dup underlying swap [ length ] 2apply - ;
+
+: full? ( resizable -- ? ) space zero? ;
+
+: end-read-loop ( buf ch state stream quot -- string/f )
+    2drop 2drop >string f like ;
+
+: decode-read-loop ( buf ch state stream encoding -- string/f )
+    >r >r pick r> r> rot full?  [ end-read-loop ] [
+        over stream-read1 [
+            -rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop
+        ] [ end-read-loop ] if*
+    ] if ;
+
+: decode-read ( length stream encoding -- string )
+    >r swap start-decoding r>
+    decode-read-loop ;
+
+GENERIC: init-decoding ( stream encoding -- decoded-stream )
+
+: <decoding> ( stream decoding-class -- decoded-stream )
+    construct-empty init-decoding <line-reader> ;
+
+GENERIC: init-encoding ( stream encoding -- encoded-stream )
+
+: <encoding> ( stream encoding-class -- encoded-stream )
+    construct-empty init-encoding <plain-writer> ;
+
+GENERIC: encode-string ( string encoding -- byte-array )
+M: tuple-class encode-string construct-empty encode-string ;
+
+MIXIN: encoding-stream
+
+M: encoding-stream init-decoding ( stream encoding-stream -- encoding-stream )
+    tuck set-delegate ;
+
+M: encoding-stream init-encoding ( stream encoding-stream -- encoding-stream )
+    tuck set-delegate ;
+
+M: encoding-stream stream-read1 1 swap stream-read ;
+
+M: encoding-stream stream-read
+    [ delegate ] keep decode-read ;
+
+M: encoding-stream stream-read-partial stream-read ;
+
+M: encoding-stream stream-read-until
+    ! Copied from { c-reader stream-read-until }!!!
+    [ swap read-until-loop ] "" make
+    swap over empty? over not and [ 2drop f f ] when ;
+
+M: encoding-stream stream-write1
+    >r 1string r> stream-write ;
+
+M: encoding-stream stream-write
+    [ encode-string ] keep delegate stream-write ;
+
+M: encoding-stream dispose delegate dispose ;

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

@@ -0,0 +1,5 @@
+USING: help.syntax help.markup ;
+IN: io.encodings.latin1
+
+HELP: latin1
+{ $class-description "This class is used for Latin 1 (ISO 8859-1) encoding and decoding" } ;

core/io/encodings/latin1/latin1.factor

@@ -0,0 +1,19 @@
+USING: io io.encodings strings kernel ;
+IN: io.encodings.latin1
+
+TUPLE: latin1 stream ;
+
+M: latin1 init-decoding tuck set-latin1-stream ;
+M: latin1 init-encoding drop ;
+
+M: latin1 stream-read1
+    latin1-stream stream-read1 ;
+
+M: latin1 stream-read
+    latin1-stream stream-read >string ;
+
+M: latin1 stream-read-until
+    latin1-stream stream-read-until >string ;
+
+M: latin1 stream-readln
+    latin1-stream stream-readln >string ;

core/io/encodings/latin1/summary.txt

@@ -0,0 +1 @@
+ISO 8859-1 encoding/decoding

core/io/encodings/latin1/tags.txt

@@ -0,0 +1 @@
+text

core/io/encodings/utf16/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

core/io/encodings/utf16/tags.txt

@@ -0,0 +1 @@
+text

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

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax io.encodings strings ;
-IN: io.utf16
+IN: io.encodings.utf16
 
 ARTICLE: "io.utf16" "Working with UTF16-encoded data"
 "The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences."

core/io/encodings/utf16/utf16.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces io.binary
 io.encodings combinators splitting ;
-IN: io.utf16
+IN: io.encodings.utf16
 
 SYMBOL: double
 SYMBOL: quad1
@@ -30,7 +30,7 @@ SYMBOL: ignore
         >r 2 shift r> BIN: 11 bitand bitor quad3
     ] [ 2drop do-ignore ] if ;
 
-: (decode-utf16be) ( buf byte ch state -- buf ch state )
+: decode-utf16be-step ( buf byte ch state -- buf ch state )
     {
         { begin [ drop begin-utf16be ] }
         { double [ end-multibyte ] }
@@ -41,7 +41,7 @@ SYMBOL: ignore
     } case ;
 
 : decode-utf16be ( seq -- str )
-    [ -rot (decode-utf16be) ] decode ;
+    [ decode-utf16be-step ] decode ;
 
 : handle-double ( buf byte ch -- buf ch state )
     swap dup -3 shift BIN: 11011 = [
@@ -55,7 +55,7 @@ SYMBOL: ignore
         BIN: 11 bitand append-nums HEX: 10000 + decoded
     ] [ 2drop push-replacement ] if ;
 
-: (decode-utf16le) ( buf byte ch state -- buf ch state )
+: decode-utf16le-step ( buf byte ch state -- buf ch state )
     {
         { begin [ drop double ] }
         { double [ handle-double ] }
@@ -65,7 +65,7 @@ SYMBOL: ignore
     } case ;
 
 : decode-utf16le ( seq -- str )
-    [ -rot (decode-utf16le) ] decode ;
+    [ decode-utf16le-step ] decode ;
 
 : encode-first
     -10 shift
@@ -104,13 +104,23 @@ SYMBOL: ignore
 : encode-utf16 ( str -- seq )
     encode-utf16le bom-le swap append ;
 
-: utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
-
-: utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
-
 : decode-utf16 ( seq -- str )
     {
-        { [ utf16le? ] [ decode-utf16le ] }
+        { [ bom-le ?head ] [ decode-utf16le ] }
-        { [ utf16be? ] [ decode-utf16be ] }
+        { [ bom-be ?head ] [ decode-utf16be ] }
         { [ t ] [ decode-error ] }
     } cond ;
+
+TUPLE: utf16le ;
+: <utf16le> utf16le construct-delegate ;
+INSTANCE: utf16le encoding-stream 
+
+M: utf16le encode-string drop encode-utf16le ;
+M: utf16le decode-step drop decode-utf16le-step ;
+
+TUPLE: utf16be ;
+: <utf16be> utf16be construct-delegate ;
+INSTANCE: utf16be encoding-stream 
+
+M: utf16be encode-string drop encode-utf16be ;
+M: utf16be decode-step drop decode-utf16be-step ;

core/io/encodings/utf8/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

core/io/encodings/utf8/tags.txt

@@ -0,0 +1 @@
+text

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

@@ -1,12 +1,12 @@
 USING: help.markup help.syntax io.encodings strings ;
-IN: io.utf8
+IN: io.encodings.utf8
 
-ARTICLE: "io.utf8" "Working with UTF8-encoded data"
+ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
 "The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences."
 { $subsection encode-utf8 }
 { $subsection decode-utf8 } ;
 
-ABOUT: "io.utf8"
+ABOUT: "io.encodings.utf8"
 
 HELP: decode-utf8
 { $values { "seq" "a sequence of bytes" } { "str" string } }

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

@@ -0,0 +1,23 @@
+USING: io.encodings.utf8 tools.test sbufs kernel io
+sequences strings arrays unicode.syntax ;
+
+: decode-utf8-w/stream ( array -- newarray )
+    >sbuf dup reverse-here <utf8> contents >array ;
+
+: encode-utf8-w/stream ( array -- newarray )
+    SBUF" " clone tuck <utf8> write >array ;
+
+[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
+
+[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
+
+[ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test
+
+[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
+
+[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
+
+[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
+
+[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
+[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test

core/io/encodings/utf8/utf8.factor

@@ -1,8 +1,10 @@
 ! Copyright (C) 2006, 2007 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors
+USING: math kernel sequences sbufs vectors growable io continuations
-namespaces io.encodings combinators ;
+namespaces io.encodings combinators strings io.streams.c ;
-IN: io.utf8
+IN: io.encodings.utf8
+
+! Decoding UTF-8
 
 SYMBOL: double
 SYMBOL: triple
@@ -31,7 +33,7 @@ SYMBOL: quad3
 : end-multibyte ( buf byte ch -- buf ch state )
     f append-nums [ decoded ] unless* ;
 
-: (decode-utf8) ( buf byte ch state -- buf ch state )
+: decode-utf8-step ( buf byte ch state -- buf ch state )
     {
         { begin [ drop begin-utf8 ] }
         { double [ end-multibyte ] }
@@ -43,7 +45,9 @@ SYMBOL: quad3
     } case ;
 
 : decode-utf8 ( seq -- str )
-    [ -rot (decode-utf8) ] decode ;
+    [ decode-utf8-step ] decode ; 
+
+! Encoding UTF-8
 
 : encoded ( char -- )
     BIN: 111111 bitand BIN: 10000000 bitor , ;
@@ -70,3 +74,13 @@ SYMBOL: quad3
 
 : encode-utf8 ( str -- seq )
     [ [ char>utf8 ] each ] B{ } make ;
+
+! Interface for streams
+
+TUPLE: utf8 ;
+: <utf8> utf8 construct-delegate ;
+INSTANCE: utf8 encoding-stream 
+
+M: utf8 encode-string drop encode-utf8 ;
+M: utf8 decode-step drop decode-utf8-step ;
+! In the future, this should detect and ignore a BOM at the beginning

core/io/utf8/utf8-tests.factor

@@ -1,16 +0,0 @@
-USING: io.utf8 tools.test strings arrays unicode.syntax ;
-
-[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8 >array ] unit-test
-
-[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
-
-[ "x" ] [ "x" decode-utf8 >string ] unit-test
-
-[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8 >array ] unit-test
-
-[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8 >array ] unit-test
-
-[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
-
-[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
-[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test

core/optimizer/backend/backend.factor

@@ -3,8 +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 generic.math continuations optimizer.def-use
+combinators classes optimizer.def-use ;
-optimizer.pattern-match generic.standard optimizer.specializers ;
 IN: optimizer.backend
 
 SYMBOL: class-substitutions
@@ -68,8 +67,6 @@ DEFER: optimize-nodes
         ] if
     ] when ;
 
-M: f set-node-successor 2drop ;
-
 : optimize-nodes ( node -- newnode )
     [
         class-substitutions [ clone ] change
@@ -78,19 +75,9 @@ M: f set-node-successor 2drop ;
         optimizer-changed get
     ] with-scope optimizer-changed set ;
 
-! Generic nodes
 M: node optimize-node* drop t f ;
 
-: cleanup-inlining ( node -- newnode changed? )
+! Post-inlining cleanup
-    node-successor [ node-successor t ] [ t f ] if* ;
-
-! #return
-M: #return optimize-node* cleanup-inlining ;
-
-! #values
-M: #values optimize-node* cleanup-inlining ;
-
-! Some utilities for splicing in dataflow IR subtrees
 : follow ( key assoc -- value )
     2dup at* [ swap follow nip ] [ 2drop ] if ;
 
@@ -103,282 +90,30 @@ M: #values optimize-node* cleanup-inlining ;
     #! Not very efficient.
     dupd union* update ;
 
-: post-inline ( #call/#merge #return/#values -- assoc )
+: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
-    >r node-out-d r> node-in-d 2array unify-lengths flip
+    node-out-d swap node-in-d 2array unify-lengths flip
     [ = not ] assoc-subset >hashtable ;
 
-: substitute-def-use ( node -- )
+: cleanup-inlining ( #return/#values -- newnode changed? )
-    #! As a first approximation, we take all the values used
+    dup node-successor dup [
-    #! by the set of new nodes, and push a 't' on their
+        class-substitutions get pick node-classes update
-    #! def-use list here. We could perform a full graph
+        literal-substitutions get pick node-literals update
-    #! substitution, but we don't need to, because the next
+        tuck compute-value-substitutions value-substitutions get swap update*
-    #! optimizer iteration will do that. We just need a minimal
+        node-successor t
-    #! degree of accuracy; the new values should be marked as
+    ] [
-    #! having _some_ usage, so that flushing doesn't erronously
+        2drop t f
-    #! flush them away.
+    ] if ;
-    [ compute-def-use def-use get keys ] with-scope
-    def-use get [ [ t swap ?push ] change-at ] curry each ;
 
-: substitute-node ( old new -- )
+! #return
-    #! The last node of 'new' becomes 'old', then values are
+M: #return optimize-node* cleanup-inlining ;
-    #! substituted. A subsequent optimizer phase kills the
-    #! last node of 'new' and the first node of 'old'.
-    dup substitute-def-use
-    last-node
-    class-substitutions get over node-classes update
-    literal-substitutions get over node-literals update
-    2dup post-inline value-substitutions get swap update*
-    set-node-successor ;
 
-GENERIC: remember-method* ( method-spec node -- )
+! #values
+M: #values optimize-node* cleanup-inlining ;
 
-M: #call remember-method*
+M: f set-node-successor 2drop ;
-    [ node-history ?push ] keep set-node-history ;
 
-M: node remember-method*
+: splice-node ( old new -- )
-    2drop ;
+    dup splice-def-use last-node set-node-successor ;
-
-: remember-method ( method-spec node -- )
-    swap dup second +inlined+ depends-on
-    [ swap remember-method* ] curry each-node ;
-
-: (splice-method) ( #call method-spec quot -- node )
-    #! Must remember the method before splicing in, otherwise
-    #! the rest of the IR will also remember the method
-    pick node-in-d dataflow-with
-    [ remember-method ] keep
-    [ swap infer-classes/node ] 2keep
-    [ substitute-node ] keep ;
-
-: splice-quot ( #call quot -- node )
-    over node-in-d dataflow-with
-    [ swap infer-classes/node ] 2keep
-    [ substitute-node ] keep ;
 
 : drop-inputs ( node -- #shuffle )
     node-in-d clone \ #shuffle in-node ;
-
-! Constant branch folding
-: fold-branch ( node branch# -- node )
-    over node-children nth
-    swap node-successor over substitute-node ;
-
-! #if
-: known-boolean-value? ( node value -- value ? )
-    2dup node-literal? [
-        node-literal t
-    ] [
-        node-class {
-            { [ dup null class< ] [ drop f f ] }
-            { [ dup general-t class< ] [ drop t t ] }
-            { [ dup \ f class< ] [ drop f t ] }
-            { [ t ] [ drop f f ] }
-        } cond
-    ] if ;
-
-M: #if optimize-node*
-    dup dup node-in-d first known-boolean-value? [
-        over drop-inputs >r
-        0 1 ? fold-branch
-        r> [ set-node-successor ] keep
-        t
-    ] [ 2drop t f ] if ;
-
-M: #dispatch optimize-node*
-    dup dup node-in-d first 2dup node-literal? [
-        "Optimizing #dispatch" print
-        node-literal
-        over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
-    ] [
-        3drop t f
-    ] if ;
-
-! #call
-: splice-method ( #call method-spec/t quot/t -- node/t )
-    #! t indicates failure
-    {
-        { [ dup t eq? ] [ 3drop t ] }
-        { [ 2over swap node-history member? ] [ 3drop t ] }
-        { [ t ] [ (splice-method) ] }
-    } cond ;
-
-! Single dispatch method inlining optimization
-: already-inlined? ( node -- ? )
-    #! Was this node inlined from definition of 'word'?
-    dup node-param swap node-history memq? ;
-
-: specific-method ( class word -- class ) order min-class ;
-
-: node-class# ( node n -- class )
-    over node-in-d <reversed> ?nth node-class ;
-
-: dispatching-class ( node word -- class )
-    [ dispatch# node-class# ] keep specific-method ;
-
-! A heuristic to avoid excessive inlining
-DEFER: (flat-length)
-
-: word-flat-length ( word -- n )
-    dup get over inline? not or
-    [ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
-
-: (flat-length) ( seq -- n )
-    [
-        {
-            { [ dup quotation? ] [ (flat-length) 1+ ] }
-            { [ dup array? ] [ (flat-length) ] }
-            { [ dup word? ] [ word-flat-length ] }
-            { [ t ] [ drop 1 ] }
-        } cond
-    ] map sum ;
-
-: flat-length ( seq -- n )
-    [ word-def (flat-length) ] with-scope ;
-
-: will-inline-method ( node word -- method-spec/t quot/t )
-    #! t indicates failure
-    tuck dispatching-class dup [
-        swap [ 2array ] 2keep
-        method method-word
-        dup flat-length 10 >=
-        [ 1quotation ] [ word-def ] if
-    ] [
-        2drop t t
-    ] if ;
-
-: inline-standard-method ( node word -- node )
-    dupd will-inline-method splice-method ;
-
-! Partial dispatch of math-generic words
-: math-both-known? ( word left right -- ? )
-    math-class-max swap specific-method ;
-
-: will-inline-math-method ( word left right -- method-spec/t quot/t )
-    #! t indicates failure
-    3dup math-both-known?
-    [ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
-
-: inline-math-method ( #call word -- node )
-    over node-input-classes first2
-    will-inline-math-method splice-method ;
-
-: inline-method ( #call -- node )
-    dup node-param {
-        { [ dup standard-generic? ] [ inline-standard-method ] }
-        { [ dup math-generic? ] [ inline-math-method ] }
-        { [ t ] [ 2drop t ] }
-    } cond ;
-
-! Resolve type checks at compile time where possible
-: comparable? ( actual testing -- ? )
-    #! If actual is a subset of testing or if the two classes
-    #! are disjoint, return t.
-    2dup class< >r classes-intersect? not r> or ;
-
-: optimize-predicate? ( #call -- ? )
-    dup node-param "predicating" word-prop dup [
-        >r node-class-first r> comparable?
-    ] [
-        2drop f
-    ] if ;
-
-: literal-quot ( node literals -- quot )
-    #! Outputs a quotation which drops the node's inputs, and
-    #! pushes some literals.
-    >r node-in-d length \ drop <repetition>
-    r> [ literalize ] map append >quotation ;
-
-: inline-literals ( node literals -- node )
-    #! Make #shuffle -> #push -> #return -> successor
-    dupd literal-quot splice-quot ;
-
-: evaluate-predicate ( #call -- ? )
-    dup node-param "predicating" word-prop >r
-    node-class-first r> class< ;
-
-: optimize-predicate ( #call -- node )
-    dup evaluate-predicate swap
-    dup node-successor #if? [
-        dup drop-inputs >r
-        node-successor swap 0 1 ? fold-branch
-        r> [ set-node-successor ] keep
-    ] [
-        swap 1array inline-literals
-    ] if ;
-
-: optimizer-hooks ( node -- conditions )
-    node-param "optimizer-hooks" word-prop ;
-
-: optimizer-hook ( node -- pair/f )
-    dup optimizer-hooks [ first call ] find 2nip ;
-
-: optimize-hook ( node -- )
-    dup optimizer-hook second call ;
-
-: define-optimizers ( word optimizers -- )
-    "optimizer-hooks" set-word-prop ;
-
-: flush-eval? ( #call -- ? )
-    dup node-param "flushable" word-prop [
-        node-out-d [ unused? ] all?
-    ] [
-        drop f
-    ] if ;
-
-: flush-eval ( #call -- node )
-    dup node-param +inlined+ depends-on
-    dup node-out-d length f <repetition> inline-literals ;
-
-: partial-eval? ( #call -- ? )
-    dup node-param "foldable" word-prop [
-        dup node-in-d [ node-literal? ] with all?
-    ] [
-        drop f
-    ] if ;
-
-: literal-in-d ( #call -- inputs )
-    dup node-in-d [ node-literal ] with map ;
-
-: partial-eval ( #call -- node )
-    dup node-param +inlined+ depends-on
-    dup literal-in-d over node-param 1quotation
-    [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
-
-: define-identities ( words identities -- )
-    [ "identities" set-word-prop ] curry each ;
-
-: find-identity ( node -- quot )
-    [ node-param "identities" word-prop ] keep
-    [ swap first in-d-match? ] curry find
-    nip dup [ second ] when ;
-
-: apply-identities ( node -- node/f )
-    dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
-
-: optimistic-inline? ( #call -- ? )
-    dup node-param "specializer" word-prop dup [
-        >r node-input-classes r> specialized-length tail*
-        [ types length 1 = ] all?
-    ] [
-        2drop f
-    ] if ;
-
-: optimistic-inline ( #call -- node )
-    dup node-param dup +inlined+ depends-on
-    word-def splice-quot ;
-
-: method-body-inline? ( #call -- ? )
-    node-param dup method-body?
-    [ flat-length 8 <= ] [ drop f ] if ;
-
-M: #call optimize-node*
-    {
-        { [ dup flush-eval? ] [ flush-eval ] }
-        { [ dup partial-eval? ] [ partial-eval ] }
-        { [ dup find-identity ] [ apply-identities ] }
-        { [ dup optimizer-hook ] [ optimize-hook ] }
-        { [ dup optimize-predicate? ] [ optimize-predicate ] }
-        { [ dup optimistic-inline? ] [ optimistic-inline ] }
-        { [ dup method-body-inline? ] [ optimistic-inline ] }
-        { [ t ] [ inline-method ] }
-    } cond dup not ;

core/optimizer/control/control.factor

@@ -1,9 +1,60 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel inference.dataflow combinators sequences
+USING: arrays generic assocs inference inference.class
-namespaces math ;
+inference.dataflow inference.backend inference.state io kernel
+math namespaces sequences vectors words quotations hashtables
+combinators classes generic.math continuations optimizer.def-use
+optimizer.backend generic.standard ;
 IN: optimizer.control
 
+! ! ! Loop detection
+
+! A LOOP
+!
+!          #label A
+!             |
+!            #if ----> #merge ----> #return
+!             |
+!       -------------
+!       |           |
+! #call-label A     |
+!       |          ...
+!    #values
+!
+! NOT A LOOP (call to A not in tail position):
+!
+!
+!          #label A
+!             |
+!            #if ----> ... ----> #merge ----> #return
+!             |
+!       -------------
+!       |           |
+! #call-label A     |
+!       |          ...
+!      ...
+!       |
+!    #values
+!
+! NOT A LOOP (call to A nested inside another label/loop):
+!
+!
+!          #label A
+!             |
+!            #if ----> #merge ----> ... ----> #return
+!             |
+!       -------------
+!       |           |
+!      ...      #label B
+!                   |
+!                  #if -> ...
+!                   |
+!               ---------
+!               |       |
+!         #call-label A |
+!               |       |
+!              ...     ...
+
 GENERIC: detect-loops* ( node -- )
 
 M: node detect-loops* drop ;
@@ -34,3 +85,201 @@ M: #call-label detect-loops*
 
 : detect-loops ( node -- )
     [ detect-loops* ] each-node ;
+
+! ! ! Constant branch folding
+!
+! BEFORE
+!
+!      #if ----> #merge ----> C
+!       |
+!   ---------
+!   |       |
+!   A       B
+!   |       |
+! #values   |
+!        #values
+!
+! AFTER
+!
+!       |
+!       A
+!       |
+!    #values
+!       |
+!    #merge
+!       |
+!       C
+
+: fold-branch ( node branch# -- node )
+    over node-children nth
+    swap node-successor over splice-node ;
+
+! #if
+: known-boolean-value? ( node value -- value ? )
+    2dup node-literal? [
+        node-literal t
+    ] [
+        node-class {
+            { [ dup null class< ] [ drop f f ] }
+            { [ dup general-t class< ] [ drop t t ] }
+            { [ dup \ f class< ] [ drop f t ] }
+            { [ t ] [ drop f f ] }
+        } cond
+    ] if ;
+
+: fold-if-branch? dup node-in-d first known-boolean-value? ;
+
+: fold-if-branch ( node value -- node' )
+    over drop-inputs >r
+    0 1 ? fold-branch
+    r> [ set-node-successor ] keep ;
+
+! ! ! Lifting code after a conditional if one branch throws
+: only-one ( seq -- elt/f )
+    dup length 1 = [ first ] [ drop f ] if ;
+
+: lift-throw-tail? ( #if -- tail/? )
+    dup node-successor #tail?
+    [ drop f ] [ active-children only-one ] if ;
+
+: clone-node ( node -- newnode )
+    clone dup [ clone ] modify-values ;
+
+! BEFORE
+!
+!         #if ----> #merge ----> B ----> #return/#values
+!          |
+!          |
+!      ---------
+!      |       |
+!      |       A
+! #terminate   |
+!           #values
+!
+! AFTER
+!
+!         #if ----> #merge (*) ----> #return/#values (**)
+!          |
+!          |
+!      ---------
+!      |       |
+!      |       A
+! #terminate   |
+!           #values
+!              |
+!           #merge (***)
+!              |
+!              B
+!              |
+!        #return/#values
+!
+! (*) has the same outputs as the inputs of (**), and it is not
+! the same node as (***)
+!
+! Note: if (**) is #return is is sound to put #terminate there,
+! but not if (**) is #values
+
+: lift-branch
+    over
+    last-node clone-node
+    dup node-in-d \ #merge out-node
+    [ set-node-successor ] keep -rot
+    >r dup node-successor r> splice-node
+    set-node-successor ;
+
+M: #if optimize-node*
+    dup fold-if-branch? [ fold-if-branch t ] [
+        drop dup lift-throw-tail? dup [
+            dupd lift-branch t
+        ] [
+            2drop t f
+        ] if
+    ] if ;
+
+: fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
+
+: fold-dispatch-branch ( node value -- node' )
+    dupd node-literal
+    over drop-inputs >r fold-branch r>
+    [ set-node-successor ] keep ;
+
+M: #dispatch optimize-node*
+    dup fold-dispatch-branch? [
+        fold-dispatch-branch t
+    ] [
+        2drop t f
+    ] if ;
+
+! Loop tail hoising: code after a loop can sometimes go in the
+! non-recursive branch of the loop
+
+! BEFORE:
+
+!   #label -> C -> #return 1
+!     |
+!     -> #if -> #merge -> #return 2
+!         |
+!     --------
+!     |      |
+!     A      B
+!     |      |
+!  #values   |
+!        #call-label
+!            |
+!            |
+!         #values
+
+! AFTER:
+
+!    #label -> #terminate
+!     |
+!     -> #if -> #terminate
+!         |
+!     --------
+!     |      |
+!     A      B
+!     |      |
+!  #values   |
+!     |  #call-label
+!  #merge    |
+!     |      |
+!     C   #values
+!     |
+!  #return 1
+
+: find-final-if ( node -- #if/f )
+    dup [
+        dup #if? [
+            dup node-successor #tail? [
+                node-successor find-final-if
+            ] unless
+        ] [
+            node-successor find-final-if
+        ] if
+    ] when ;
+
+: detach-node-successor ( node -- successor )
+    dup node-successor #terminate rot set-node-successor ;
+
+: lift-loop-tail? ( #label -- tail/f )
+    dup node-successor node-successor [
+        dup node-param swap node-child find-final-if dup [
+            node-children [ penultimate-node ] map
+            [
+                dup #call-label?
+                [ node-param eq? not ] [ 2drop t ] if
+            ] with subset only-one
+        ] [ 2drop f ] if
+    ] [ drop f ] if ;
+
+! M: #loop optimize-node*
+!     dup lift-loop-tail? dup [
+!         last-node >r
+!         dup detach-node-successor
+!         over node-child find-final-if detach-node-successor
+!         [ set-node-successor ] keep
+!         r> set-node-successor
+!         t
+!     ] [
+!         2drop t f
+!     ] if ;

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

@@ -70,20 +70,6 @@ M: #branch node-def-use
     #! #values node.
     dup branch-def-use (node-def-use) ;
 
-! : dead-literals ( -- values )
-!     def-use get [ >r value? r> empty? and ] assoc-subset ;
-! 
-! : kill-node* ( node values -- )
-!     [ swap remove-all ] curry modify-values ;
-! 
-! : kill-node ( node values -- )
-!     dup assoc-empty?
-!     [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
-! 
-! : kill-values ( node -- )
-!     #! Remove literals which are not actually used anywhere.
-!     dead-literals kill-node ;
-
 : compute-dead-literals ( -- values )
     def-use get [ >r value? r> empty? and ] assoc-subset ;
 
@@ -129,8 +115,18 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
         dead-literals [ kill-nodes ] with-variable
     ] if ;
 
-!
-
 : sole-consumer ( #call -- node/f )
     node-out-d first used-by
     dup length 1 = [ first ] [ drop f ] if ;
+
+: splice-def-use ( node -- )
+    #! As a first approximation, we take all the values used
+    #! by the set of new nodes, and push a 't' on their
+    #! def-use list here. We could perform a full graph
+    #! substitution, but we don't need to, because the next
+    #! optimizer iteration will do that. We just need a minimal
+    #! 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
+    def-use get [ [ t swap ?push ] change-at ] curry each ;

core/optimizer/inlining/inlining.factor

@@ -0,0 +1,227 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays generic assocs inference inference.class
+inference.dataflow inference.backend inference.state io kernel
+math namespaces sequences vectors words quotations hashtables
+combinators classes generic.math continuations optimizer.def-use
+optimizer.backend generic.standard optimizer.specializers
+optimizer.def-use optimizer.pattern-match generic.standard
+optimizer.control ;
+IN: optimizer.inlining
+
+GENERIC: remember-method* ( method-spec node -- )
+
+M: #call remember-method*
+    [ node-history ?push ] keep set-node-history ;
+
+M: node remember-method*
+    2drop ;
+
+: remember-method ( method-spec node -- )
+    swap dup second +inlined+ depends-on
+    [ swap remember-method* ] curry each-node ;
+
+: (splice-method) ( #call method-spec quot -- node )
+    #! Must remember the method before splicing in, otherwise
+    #! the rest of the IR will also remember the method
+    pick node-in-d dataflow-with
+    [ remember-method ] keep
+    [ swap infer-classes/node ] 2keep
+    [ splice-node ] keep ;
+
+: splice-quot ( #call quot -- node )
+    over node-in-d dataflow-with
+    [ swap infer-classes/node ] 2keep
+    [ splice-node ] keep ;
+
+! #call
+: splice-method ( #call method-spec/t quot/t -- node/t )
+    #! t indicates failure
+    {
+        { [ dup t eq? ] [ 3drop t ] }
+        { [ 2over swap node-history member? ] [ 3drop t ] }
+        { [ t ] [ (splice-method) ] }
+    } cond ;
+
+! Single dispatch method inlining optimization
+: already-inlined? ( node -- ? )
+    #! Was this node inlined from definition of 'word'?
+    dup node-param swap node-history memq? ;
+
+: specific-method ( class word -- class ) order min-class ;
+
+: node-class# ( node n -- class )
+    over node-in-d <reversed> ?nth node-class ;
+
+: dispatching-class ( node word -- class )
+    [ dispatch# node-class# ] keep specific-method ;
+
+! A heuristic to avoid excessive inlining
+DEFER: (flat-length)
+
+: word-flat-length ( word -- n )
+    dup get over inline? not or
+    [ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
+
+: (flat-length) ( seq -- n )
+    [
+        {
+            { [ dup quotation? ] [ (flat-length) 1+ ] }
+            { [ dup array? ] [ (flat-length) ] }
+            { [ dup word? ] [ word-flat-length ] }
+            { [ t ] [ drop 1 ] }
+        } cond
+    ] map sum ;
+
+: flat-length ( seq -- n )
+    [ word-def (flat-length) ] with-scope ;
+
+: will-inline-method ( node word -- method-spec/t quot/t )
+    #! t indicates failure
+    tuck dispatching-class dup [
+        swap [ 2array ] 2keep
+        method method-word
+        dup flat-length 10 >=
+        [ 1quotation ] [ word-def ] if
+    ] [
+        2drop t t
+    ] if ;
+
+: inline-standard-method ( node word -- node )
+    dupd will-inline-method splice-method ;
+
+! Partial dispatch of math-generic words
+: math-both-known? ( word left right -- ? )
+    math-class-max swap specific-method ;
+
+: will-inline-math-method ( word left right -- method-spec/t quot/t )
+    #! t indicates failure
+    3dup math-both-known?
+    [ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
+
+: inline-math-method ( #call word -- node )
+    over node-input-classes first2
+    will-inline-math-method splice-method ;
+
+: inline-method ( #call -- node )
+    dup node-param {
+        { [ dup standard-generic? ] [ inline-standard-method ] }
+        { [ dup math-generic? ] [ inline-math-method ] }
+        { [ t ] [ 2drop t ] }
+    } cond ;
+
+! Resolve type checks at compile time where possible
+: comparable? ( actual testing -- ? )
+    #! If actual is a subset of testing or if the two classes
+    #! are disjoint, return t.
+    2dup class< >r classes-intersect? not r> or ;
+
+: optimize-predicate? ( #call -- ? )
+    dup node-param "predicating" word-prop dup [
+        >r node-class-first r> comparable?
+    ] [
+        2drop f
+    ] if ;
+
+: literal-quot ( node literals -- quot )
+    #! Outputs a quotation which drops the node's inputs, and
+    #! pushes some literals.
+    >r node-in-d length \ drop <repetition>
+    r> [ literalize ] map append >quotation ;
+
+: inline-literals ( node literals -- node )
+    #! Make #shuffle -> #push -> #return -> successor
+    dupd literal-quot splice-quot ;
+
+: evaluate-predicate ( #call -- ? )
+    dup node-param "predicating" word-prop >r
+    node-class-first r> class< ;
+
+: optimize-predicate ( #call -- node )
+    #! If the predicate is followed by a branch we fold it
+    #! immediately
+    dup evaluate-predicate swap
+    dup node-successor #if? [
+        dup drop-inputs >r
+        node-successor swap 0 1 ? fold-branch
+        r> [ set-node-successor ] keep
+    ] [
+        swap 1array inline-literals
+    ] if ;
+
+: optimizer-hooks ( node -- conditions )
+    node-param "optimizer-hooks" word-prop ;
+
+: optimizer-hook ( node -- pair/f )
+    dup optimizer-hooks [ first call ] find 2nip ;
+
+: optimize-hook ( node -- )
+    dup optimizer-hook second call ;
+
+: define-optimizers ( word optimizers -- )
+    "optimizer-hooks" set-word-prop ;
+
+: flush-eval? ( #call -- ? )
+    dup node-param "flushable" word-prop [
+        node-out-d [ unused? ] all?
+    ] [
+        drop f
+    ] if ;
+
+: flush-eval ( #call -- node )
+    dup node-param +inlined+ depends-on
+    dup node-out-d length f <repetition> inline-literals ;
+
+: partial-eval? ( #call -- ? )
+    dup node-param "foldable" word-prop [
+        dup node-in-d [ node-literal? ] with all?
+    ] [
+        drop f
+    ] if ;
+
+: literal-in-d ( #call -- inputs )
+    dup node-in-d [ node-literal ] with map ;
+
+: partial-eval ( #call -- node )
+    dup node-param +inlined+ depends-on
+    dup literal-in-d over node-param 1quotation
+    [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
+
+: define-identities ( words identities -- )
+    [ "identities" set-word-prop ] curry each ;
+
+: find-identity ( node -- quot )
+    [ node-param "identities" word-prop ] keep
+    [ swap first in-d-match? ] curry find
+    nip dup [ second ] when ;
+
+: apply-identities ( node -- node/f )
+    dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
+
+: optimistic-inline? ( #call -- ? )
+    dup node-param "specializer" word-prop dup [
+        >r node-input-classes r> specialized-length tail*
+        [ types length 1 = ] all?
+    ] [
+        2drop f
+    ] if ;
+
+: optimistic-inline ( #call -- node )
+    dup node-param dup +inlined+ depends-on
+    word-def splice-quot ;
+
+: method-body-inline? ( #call -- ? )
+    node-param dup method-body?
+    [ flat-length 8 <= ] [ drop f ] if ;
+
+M: #call optimize-node*
+    {
+        { [ dup flush-eval? ] [ flush-eval ] }
+        { [ dup partial-eval? ] [ partial-eval ] }
+        { [ dup find-identity ] [ apply-identities ] }
+        { [ dup optimizer-hook ] [ optimize-hook ] }
+        { [ dup optimize-predicate? ] [ optimize-predicate ] }
+        { [ dup optimistic-inline? ] [ optimistic-inline ] }
+        { [ dup method-body-inline? ] [ optimistic-inline ] }
+        { [ t ] [ inline-method ] }
+    } cond dup not ;

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

@@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
 io.streams.string layouts splitting math.intervals
 math.floats.private tuples tuples.private classes
 optimizer.def-use optimizer.backend optimizer.pattern-match
-float-arrays sequences.private combinators ;
+optimizer.inlining float-arrays sequences.private combinators ;
 
 ! the output of <tuple> and <tuple-boa> has the class which is
 ! its second-to-last input

core/optimizer/math/math.factor

@@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io
 namespaces assocs quotations math.intervals sequences.private
 combinators splitting layouts math.parser classes generic.math
 optimizer.pattern-match optimizer.backend optimizer.def-use
-generic.standard system ;
+optimizer.inlining generic.standard system ;
 
 { + bignum+ float+ fixnum+fast } {
     { { number 0 } [ drop ] }

core/optimizer/optimizer-tests.factor

@@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
 kernel.private math optimizer prettyprint sequences sbufs
 strings tools.test vectors words sequences.private quotations
 optimizer.backend classes inference.dataflow tuples.private
-continuations growable ;
+continuations growable optimizer.inlining ;
 IN: temporary
 
 [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@@ -301,3 +301,31 @@ TUPLE: silly-tuple a b ;
 [ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
 [ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
 [ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
+
+! Regression
+: lift-throw-tail-regression
+    dup integer? [ "an integer" ] [
+        dup string? [ "a string" ] [
+            "error" throw
+        ] if
+    ] if ;
+
+[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
+[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
+[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
+
+: lift-loop-tail-test-1 ( a quot -- )
+    over even? [
+        [ >r 3 - r> call ] keep lift-loop-tail-test-1
+    ] [
+        over 0 < [
+            2drop
+        ] [
+            [ >r 2 - r> call ] keep lift-loop-tail-test-1
+        ] if
+    ] if ; inline
+
+: lift-loop-tail-test-2
+    10 [ ] lift-loop-tail-test-1 1 2 3 ;
+
+[ 1 2 3 ] [ lift-loop-tail-test-2 ] 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
-inference.class ;
+optimizer.inlining inference.class ;
 IN: optimizer
 
 : optimize-1 ( node -- newnode ? )
@@ -12,7 +12,7 @@ IN: optimizer
         H{ } clone value-substitutions set
         dup compute-def-use
         kill-values
-        ! dup detect-loops
+        dup detect-loops
         dup infer-classes
         optimizer-changed off
         optimize-nodes

core/optimizer/specializers/specializers.factor

@@ -24,7 +24,7 @@ IN: optimizer.specializers
         \ dispatch ,
     ] [ ] make ;
 
-: specializer-methods ( word -- alist )
+: specializer-methods ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
         [ declare ] curry pick append

extra/benchmark/benchmark.factor

@@ -8,7 +8,7 @@ IN: benchmark
 : run-benchmark ( vocab -- result )
     "=== Benchmark " write dup print flush
     dup require
-    [ [ run ] benchmark ] [ error. f f ] recover 2array
+    [ [ run ] benchmark ] [ error. drop f f ] recover 2array
     dup . ;
 
 : run-benchmarks ( -- assoc )

extra/benchmark/sockets/sockets.factor

@@ -22,7 +22,7 @@ IN: benchmark.sockets
         CHAR: x write1
     ] with-stream ;
 
-: socket-benchmark ( n -- )
+: clients ( n -- )
     dup pprint " clients: " write
         [
         [ simple-server ] in-thread
@@ -33,11 +33,12 @@ IN: benchmark.sockets
     ] time ;
 
 : socket-benchmarks
-    10 socket-benchmark
+    10 clients
-    20 socket-benchmark
+    20 clients
-    40 socket-benchmark
+    40 clients
-    80 socket-benchmark
+    80 clients
-    160 socket-benchmark
+    160 clients
-    320 socket-benchmark ;
+    320 clients
+    640 clients ;
 
 MAIN: socket-benchmarks

extra/builder/builder.factor

@@ -3,68 +3,18 @@ USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
        arrays system continuations namespaces sequences splitting math.parser
        prettyprint tools.time calendar bake vars http.client
        combinators bootstrap.image bootstrap.image.download
-       combinators.cleave benchmark ;
+       combinators.cleave benchmark
+       classes strings quotations words parser-combinators new-slots accessors
+       assocs.lib smtp builder.util ;
 
 IN: builder
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: runtime ( quot -- time ) benchmark nip ;
-
-: minutes>ms ( min -- ms ) 60 * 1000 * ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-recipients
-
-: host-name* ( -- name ) host-name "." split first ;
-
-: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
-
-: email-string ( subject -- )
-  `{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
-  [ ] with-process-stream drop ;
-
-: email-file ( subject file -- )
-  `{
-    { +stdin+ , }
-    { +arguments+
-      { "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
-  }
-  >hashtable run-process drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
-
-: factor-binary ( -- name )
-  os
-  { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
-    { "winnt" [ "./factor-nt.exe" ] }
-    [ drop "./factor" ] }
-  case ;
-
-: git-pull ( -- desc )
-  {
-    "git"
-    "pull"
-    "--no-summary"
-    "git://factorcode.org/git/factor.git"
-    "master"
-  } ;
-
 : git-clone ( -- desc ) { "git" "clone" "../factor" } ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: datestamp ( -- string )
-  now `{ ,[ dup timestamp-year   ]
-         ,[ dup timestamp-month  ]
-         ,[ dup timestamp-day    ]
-         ,[ dup timestamp-hour   ]
-         ,[     timestamp-minute ] }
-  [ pad-00 ] map "-" join ;
-
 VAR: stamp
 
 : enter-build-dir ( -- )
@@ -82,47 +32,41 @@ VAR: stamp
 
 : make-clean ( -- desc ) { "make" "clean" } ;
 
-: make-vm ( -- )
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  `{
+
-     { +arguments+ { "make" ,[ target ] } }
+: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
-     { +stdout+    "../compile-log" }
+
-     { +stderr+    +stdout+ }
+: make-vm ( -- desc )
-   }
+  <process*>
-  >hashtable ;
+    { "make" target } to-strings >>arguments
+    "../compile-log"             >>stdout
+    +stdout+                     >>stderr
+  >desc ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: factor-binary ( -- name )
+  os
+  { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
+    { "winnt"  [ "./factor-nt.exe" ] }
+    [ drop       "./factor" ] }
+  case ;
+
+: bootstrap-cmd ( -- cmd )
+  { factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" }
+  to-strings ;
 
 : bootstrap ( -- desc )
-  `{
+  <process*>
-     { +arguments+ {
+    bootstrap-cmd >>arguments
-                     ,[ factor-binary ]
+    +closed+      >>stdin
-                     ,[ "-i=" my-boot-image-name append ]
+    "../boot-log" >>stdout
-                     "-no-user-init"
+    +stdout+      >>stderr
-                   } }
+    20 minutes>ms >>timeout
-     { +stdout+   "../boot-log" }
+  >desc ;
-     { +stderr+   +stdout+ }
-     { +timeout+  ,[ 20 minutes>ms ] }
-   } ;
 
-: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
+: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ;
   
-SYMBOL: build-status
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: milli-seconds>time ( n -- string )
-  1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
-
-: eval-file ( file -- obj ) <file-reader> contents eval ;
-  
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cat ( file -- ) <file-reader> contents print ;
-
-: run-or-bail ( desc quot -- )
-  [ [ try-process ] curry ]
-  [ [ throw       ] curry ]
-  bi*
-  recover ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : (build) ( -- )
@@ -146,24 +90,8 @@ SYMBOL: build-status
 
     [ my-arch download-image ] [ "Image download error" print throw ] recover
 
-    ! bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
+    bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
 
-!     bootstrap
-!       <process-stream> dup dispose process-stream-process wait-for-process
-!     zero? not
-!       [ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ]
-!     when
-
-    [
-      bootstrap
-        <process-stream> dup dispose process-stream-process wait-for-process
-      zero? not
-        [ "bootstrap non-zero" throw ]
-      when
-    ]
-    [ "Bootstrap error" print "../boot-log" cat "bootstrap" throw ]
-    recover
-        
     [ builder-test try-process ]
     [ "Builder test error" print throw ]
     recover
@@ -180,12 +108,32 @@ SYMBOL: build-status
 
   ] with-file-out ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-recipients
+
+: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
+
 : build ( -- )
   [ (build) ] [ drop ] recover
-  "report" "../report" email-file ;
+  <email>
+    "ed@factorcode.org"     >>from
+    builder-recipients get  >>to
+    "report" tag-subject    >>subject
+    "../report" file>string >>body
+  send ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: git-pull ( -- desc )
+  {
+    "git"
+    "pull"
+    "--no-summary"
+    "git://factorcode.org/git/factor.git"
+    "master"
+  } ;
+
 : updates-available? ( -- ? )
   git-id
   git-pull run-process drop

extra/builder/server/server.factor

@@ -41,28 +41,28 @@ IN: builder.server
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: build-server ( -- )
+! : build-server ( -- )
-  receive
+!   receive
-  {
+!   {
-    {
+!     {
-      "start"
+!       "start"
-      [
+!       [
-        build-status get "idle" =
+!         build-status get "idle" =
-        build-status get f      =
+!         build-status get f      =
-        or
+!         or
-        [
+!         [
-          [ [ build ] [ drop ] recover "idle" build-status set-global ]
+!           [ [ build ] [ drop ] recover "idle" build-status set-global ]
-          in-thread
+!           in-thread
-        ]
+!         ]
-        when
+!         when
-      ]
+!       ]
-    }
+!     }
 
-    {
+!     {
-      { ?from ?tag "status" }
+!       { ?from ?tag "status" }
-      [ `{ ?tag ,[ build-status get ] } ?from send ]
+!       [ `{ ?tag ,[ build-status get ] } ?from send ]
-    }
+!     }
-  }
+!   }
-  match-cond
+!   match-cond
-  build-server ;
+!   build-server ;
 

extra/builder/test/test.factor

@@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations
        prettyprint
        tools.browser
        tools.test
-       bootstrap.stage2 benchmark ;
+       bootstrap.stage2 benchmark builder.util ;
 
 IN: builder.test
 

extra/builder/util/util.factor

@@ -0,0 +1,83 @@
+
+USING: kernel words namespaces classes parser continuations
+       io io.files io.launcher io.sockets
+       math math.parser
+       combinators sequences splitting quotations arrays strings tools.time
+       parser-combinators accessors assocs.lib
+       combinators.cleave bake calendar new-slots ;
+
+IN: builder.util
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: runtime ( quot -- time ) benchmark nip ;
+
+: minutes>ms ( min -- ms ) 60 * 1000 * ;
+
+: file>string ( file -- string ) [ stdio get contents ] with-file-in ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: to-strings
+
+: to-string ( obj -- str )
+  dup class
+    {
+      { string    [ ] }
+      { quotation [ call ] }
+      { word      [ execute ] }
+      { fixnum    [ number>string ] }
+      { array     [ to-strings concat ] }
+    }
+  case ;
+
+: to-strings ( seq -- str )
+  dup [ string? ] all?
+    [ ]
+    [ [ to-string ] map flatten ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: process* arguments stdin stdout stderr timeout ;
+
+: <process*> process* construct-empty ;
+
+: >desc ( process* -- desc )
+  H{ } clone
+    over arguments>> [ +arguments+ swap put-at ] when*
+    over stdin>>     [ +stdin+     swap put-at ] when*
+    over stdout>>    [ +stdout+    swap put-at ] when*
+    over stderr>>    [ +stderr+    swap put-at ] when*
+    over timeout>>   [ +timeout+   swap put-at ] when*
+  nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: host-name* ( -- name ) host-name "." split first ;
+
+: datestamp ( -- string )
+  now `{ ,[ dup timestamp-year   ]
+         ,[ dup timestamp-month  ]
+         ,[ dup timestamp-day    ]
+         ,[ dup timestamp-hour   ]
+         ,[     timestamp-minute ] }
+  [ pad-00 ] map "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: milli-seconds>time ( n -- string )
+  1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
+
+: eval-file ( file -- obj ) <file-reader> contents eval ;
+
+: cat ( file -- ) <file-reader> contents print ;
+
+: run-or-bail ( desc quot -- )
+  [ [ try-process ] curry   ]
+  [ [ throw       ] compose ]
+  bi*
+  recover ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/const/const.factor

@@ -1,24 +0,0 @@
-USING: kernel parser words sequences ;
-IN: const
-
-: define-const ( word value -- )
-    [ parsed ] curry dupd define
-    t "parsing" set-word-prop ;
-
-: CONST:
-    CREATE scan-word dup parsing?
-    [ execute dup pop ] when define-const ; parsing
-
-: define-enum ( words -- )
-    dup length [ define-const ] 2each ;
-
-: ENUM:
-    ";" parse-tokens [ create-in ] map define-enum ; parsing
-
-: define-value ( word -- )
-    { f } clone [ first ] curry define ;
-
-: VALUE: CREATE define-value ; parsing
-
-: set-value ( value word -- )
-    word-def first set-first ;

extra/delegate/protocols/protocols.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: delegate sequences.private sequences assocs prettyprint.sections 
-io definitions kernel ;
+io definitions kernel continuations ;
 IN: delegate.protocols
 
 PROTOCOL: sequence-protocol
@@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol
     ! everything should work, just slower (with >alist)
 
 PROTOCOL: stream-protocol
-    stream-read1 stream-read stream-read-until
+    stream-read1 stream-read stream-read-until dispose
     stream-flush stream-write1 stream-write stream-format
     stream-nl make-span-stream make-block-stream stream-readln
     make-cell-stream stream-write-table ;

extra/http/http.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables io kernel math namespaces math.parser assocs
-sequences strings splitting ascii io.utf8 assocs.lib
+sequences strings splitting ascii io.encodings.utf8 assocs.lib
 namespaces unicode.case ;
 IN: http
 

extra/icfp/2006/2006.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Gavin Harrison
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences kernel.private namespaces arrays io io.files
+USING: kernel math sequences kernel.private namespaces arrays io
-    splitting io.binary math.functions vectors quotations sequences.private ;
+io.files splitting io.binary math.functions vectors quotations
+combinators ;
 IN: icfp.2006
 
 SYMBOL: regs
@@ -9,10 +10,6 @@ SYMBOL: arrays
 SYMBOL: finger
 SYMBOL: open-arrays
 
-: call-nth ( n array -- )
-    >r >fixnum r> 2dup nth quotation?
-    [ dispatch ] [ "Not a quotation" throw ] if ; inline
-
 : reg-val ( m -- n ) regs get nth ;
 
 : set-reg ( val n -- ) regs get set-nth ;
@@ -117,11 +114,21 @@ SYMBOL: open-arrays
 : run-op ( -- bool )
     advance
     {
-        [ op0 ] [ op1 ] [ op2 ] [ op3 ]
+        { 0 [ op0 ] }
-        [ op4 ] [ op5 ] [ op6 ] [ drop t ]
+        { 1 [ op1 ] }
-        [ op8 ] [ op9 ] [ op10 ] [ op11 ]
+        { 2 [ op2 ] }
-        [ op12 ] [ op13 ]
+        { 3 [ op3 ] }
-    } call-nth ;
+        { 4 [ op4 ] }
+        { 5 [ op5 ] }
+        { 6 [ op6 ] }
+        { 7 [ drop t ] }
+        { 8 [ op8 ] }
+        { 9 [ op9 ] }
+        { 10 [ op10 ] }
+        { 11 [ op11 ] }
+        { 12 [ op12 ] }
+        { 13 [ op13 ] }
+    } case ;
 
 : exec-loop ( bool -- )
     [ run-op exec-loop ] unless ;

extra/io/launcher/launcher.factor

@@ -119,7 +119,9 @@ HOOK: process-stream* io-backend ( desc -- stream process )
 TUPLE: process-stream process ;
 
 : <process-stream> ( desc -- stream )
-    >descriptor process-stream*
+    >descriptor
+    [ process-stream* ] keep
+    +timeout+ swap at [ over set-timeout ] when*
     { set-delegate set-process-stream-process }
     process-stream construct ;
 

extra/io/unix/launcher/launcher.factor

@@ -50,15 +50,16 @@ MEMO: 'arguments' ( -- parser )
 : redirect ( obj mode fd -- )
     {
         { [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
-        { [ pick +closed+ eq? ] [ close 2drop ] }
         { [ pick string? ] [ (redirect) ] }
     } cond ;
 
+: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
+
 : setup-redirection ( -- )
-    +stdin+ get read-flags 0 redirect
+    +stdin+ get ?closed read-flags 0 redirect
-    +stdout+ get write-flags 1 redirect
+    +stdout+ get ?closed write-flags 1 redirect
     +stderr+ get dup +stdout+ eq?
-    [ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
+    [ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
 
 : spawn-process ( -- )
     [

extra/io/windows/launcher/launcher.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays continuations destructors io
-io.windows io.windows.pipes libc io.nonblocking
+io.windows io.windows.nt.pipes libc io.nonblocking
 io.streams.duplex windows.types math windows.kernel32 windows
 namespaces io.launcher kernel sequences windows.errors assocs
 splitting system threads init strings combinators io.backend ;
@@ -87,75 +87,26 @@ TUPLE: CreateProcess-args
         over set-CreateProcess-args-lpEnvironment
     ] when ;
 
-: (redirect) ( path access-mode create-mode -- handle )
-    >r >r
-    normalize-pathname
-    r> ! access-mode
-    share-mode
-    security-attributes-inherit
-    r> ! create-mode
-    FILE_ATTRIBUTE_NORMAL ! flags and attributes
-    f ! template file
-    CreateFile dup invalid-handle? dup close-later ;
-
-: redirect ( obj access-mode create-mode -- handle )
-    {
-        { [ pick not ] [ 3drop f ] }
-        { [ pick +closed+ eq? ] [ 3drop t ] }
-        { [ pick string? ] [ (redirect) ] }
-    } cond ;
-
-: ?closed or dup t eq? [ drop f ] when ;
-
-: inherited-stdout ( args -- handle )
-    CreateProcess-args-stdout-pipe
-    [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
-
-: redirect-stdout ( args -- handle )
-    +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
-    swap inherited-stdout ?closed ;
-
-: inherited-stderr ( args -- handle )
-    drop STD_ERROR_HANDLE GetStdHandle ;
-
-: redirect-stderr ( args -- handle )
-    +stderr+ get
-    dup +stdout+ eq? [
-        drop
-        CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
-    ] [
-        GENERIC_WRITE CREATE_ALWAYS redirect
-        swap inherited-stderr ?closed
-    ] if ;
-
-: inherited-stdin ( args -- handle )
-    CreateProcess-args-stdin-pipe
-    [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
-
-: redirect-stdin ( args -- handle )
-    +stdin+ get GENERIC_READ OPEN_EXISTING redirect
-    swap inherited-stdin ?closed ;
-
 : fill-startup-info
     dup CreateProcess-args-lpStartupInfo
-    STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
+    STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
 
-    over redirect-stdout over set-STARTUPINFO-hStdOutput
+HOOK: fill-redirection io-backend ( args -- args )
-    over redirect-stderr over set-STARTUPINFO-hStdError
-    over redirect-stdin over set-STARTUPINFO-hStdInput
 
-    drop ;
+M: windows-ce-io fill-redirection ;
 
 : make-CreateProcess-args ( -- args )
     default-CreateProcess-args
     wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
     fill-dwCreateFlags
-    fill-lpEnvironment ;
+    fill-lpEnvironment
+    fill-startup-info ;
 
 M: windows-io run-process* ( desc -- handle )
     [
         [
-            make-CreateProcess-args fill-startup-info
+            make-CreateProcess-args
+            fill-redirection
             dup call-CreateProcess
             CreateProcess-args-lpProcessInformation <process>
         ] with-descriptor

extra/io/windows/nt/launcher/launcher.factor

@@ -3,13 +3,63 @@
 USING: alien alien.c-types arrays continuations destructors io
 io.windows libc io.nonblocking io.streams.duplex windows.types
 math windows.kernel32 windows namespaces io.launcher kernel
-sequences windows.errors assocs splitting system
+sequences windows.errors assocs splitting system strings
-io.windows.launcher io.windows.pipes ;
+io.windows.launcher io.windows.nt.pipes io.backend
+combinators ;
 IN: io.windows.nt.launcher
 
 ! The below code is based on the example given in
 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
 
+: (redirect) ( path access-mode create-mode -- handle )
+    >r >r
+    normalize-pathname
+    r> ! access-mode
+    share-mode
+    security-attributes-inherit
+    r> ! create-mode
+    FILE_ATTRIBUTE_NORMAL ! flags and attributes
+    f ! template file
+    CreateFile dup invalid-handle? dup close-later ;
+
+: redirect ( obj access-mode create-mode -- handle )
+    {
+        { [ pick not ] [ 3drop f ] }
+        { [ pick +closed+ eq? ] [ drop nip null-pipe ] }
+        { [ pick string? ] [ (redirect) ] }
+    } cond ;
+
+: ?closed or dup t eq? [ drop f ] when ;
+
+: inherited-stdout ( args -- handle )
+    CreateProcess-args-stdout-pipe
+    [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
+
+: redirect-stdout ( args -- handle )
+    +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
+    swap inherited-stdout ?closed ;
+
+: inherited-stderr ( args -- handle )
+    drop STD_ERROR_HANDLE GetStdHandle ;
+
+: redirect-stderr ( args -- handle )
+    +stderr+ get
+    dup +stdout+ eq? [
+        drop
+        CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
+    ] [
+        GENERIC_WRITE CREATE_ALWAYS redirect
+        swap inherited-stderr ?closed
+    ] if ;
+
+: inherited-stdin ( args -- handle )
+    CreateProcess-args-stdin-pipe
+    [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
+
+: redirect-stdin ( args -- handle )
+    +stdin+ get GENERIC_READ OPEN_EXISTING redirect
+    swap inherited-stdin ?closed ;
+
 : set-inherit ( handle ? -- )
     >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
 
@@ -30,14 +80,22 @@ IN: io.windows.nt.launcher
     dup pipe-out f set-inherit
     over set-CreateProcess-args-stdin-pipe ;
 
-M: windows-io process-stream*
+M: windows-nt-io fill-redirection
+    dup CreateProcess-args-lpStartupInfo
+    over redirect-stdout over set-STARTUPINFO-hStdOutput
+    over redirect-stderr over set-STARTUPINFO-hStdError
+    over redirect-stdin over set-STARTUPINFO-hStdInput
+    drop ;
+
+M: windows-nt-io process-stream*
     [
         [
             make-CreateProcess-args
 
             fill-stdout-pipe
             fill-stdin-pipe
-            fill-startup-info
+
+            fill-redirection
 
             dup call-CreateProcess
 

extra/io/windows/nt/pipes/pipes.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays destructors io io.windows libc
 windows.types math windows.kernel32 windows namespaces kernel
-sequences windows.errors assocs math.parser system random ;
+sequences windows.errors assocs math.parser system random
-IN: io.windows.pipes
+combinators ;
+IN: io.windows.nt.pipes
 
 ! This code is based on
 ! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
@@ -65,3 +66,20 @@ TUPLE: pipe in out ;
 
 : <unique-outgoing-pipe> ( -- pipe )
     unique-pipe-name <outgoing-pipe> ;
+
+! /dev/null simulation
+: null-input ( -- pipe )
+    <unique-outgoing-pipe>
+    dup pipe-out CloseHandle drop
+    pipe-in ;
+
+: null-output ( -- pipe )
+    <unique-incoming-pipe>
+    dup pipe-in CloseHandle drop
+    pipe-out ;
+
+: null-pipe ( mode -- pipe )
+    {
+        { [ dup GENERIC_READ = ] [ drop null-input ] }
+        { [ dup GENERIC_WRITE = ] [ drop null-output ] }
+    } cond ;

extra/math/analysis/analysis.factor

@@ -1,5 +1,5 @@
 USING: kernel math math.constants math.functions math.intervals
-math.vectors namespaces sequences ;
+math.vectors namespaces sequences combinators.cleave ;
 IN: math.analysis
 
 <PRIVATE

extra/multiline/multiline.factor

@@ -7,8 +7,11 @@ IN: multiline
     lexer get dup next-line lexer-line-text ;
 
 : (parse-here) ( -- )
-    next-line-text dup ";" =
+    next-line-text [
-    [ drop lexer get next-line ] [ % "\n" % (parse-here) ] if ;
+        dup ";" =
+        [ drop lexer get next-line ]
+        [ % "\n" % (parse-here) ] if
+    ] [ ";" unexpected-eof ] if* ;
 
 : parse-here ( -- str )
     [ (parse-here) ] "" make 1 head*
@@ -19,11 +22,13 @@ IN: multiline
     parse-here 1quotation define-inline ; parsing
 
 : (parse-multiline-string) ( start-index end-text -- end-index )
-    lexer get lexer-line-text 2dup start
+    lexer get lexer-line-text [
-    [ rot dupd >r >r swap subseq % r> r> length + ] [
+        2dup start
-        rot tail % "\n" % 0
+        [ rot dupd >r >r swap subseq % r> r> length + ] [
-        lexer get next-line swap (parse-multiline-string)
+            rot tail % "\n" % 0
-    ] if* ;
+            lexer get next-line swap (parse-multiline-string)
+        ] if*
+    ] [ nip unexpected-eof ] if* ;
 
 : parse-multiline-string ( end-text -- str )
     [

extra/optimizer/debugger/debugger.factor

@@ -95,14 +95,18 @@ M: #dispatch node>quot
     node-children swap [ dataflow>quot ] curry map ,
     \ dispatch , ;
 
-M: #return node>quot
-    dup node-param unparse "#return " swap append comment, ;
-
 M: #>r node>quot nip node-in-d length \ >r <array> % ;
 
 M: #r> node>quot nip node-out-d length \ r> <array> % ;
 
-M: object node>quot dup class word-name comment, ;
+M: object node>quot
+    [
+        dup class word-name %
+        " " %
+        dup node-param unparse %
+        " " %
+        dup effect-str %
+    ] "" make comment, ;
 
 : (dataflow>quot) ( ? node -- )
     dup [

extra/smtp/server/server.factor

@@ -29,6 +29,7 @@
 
 USING: combinators kernel prettyprint io io.timeouts io.server
 sequences namespaces io.sockets continuations ;
+IN: smtp.server
 
 SYMBOL: data-mode
 
@@ -55,7 +56,7 @@ SYMBOL: data-mode
             data-mode off
             "220 OK\r\n" write flush t
           ] }
-        { [ data-mode get ] [ t ] }
+        { [ data-mode get ] [ global [ print ] bind t ] }
         { [ t ] [ 
             "500 ERROR\r\n" write flush t
           ] }
@@ -68,5 +69,6 @@ SYMBOL: data-mode
             60000 stdio get set-timeout
             "220 hello\r\n" write flush
             process
+            global [ flush ] bind
         ] with-stream
     ] with-disposal ;

extra/smtp/smtp.factor

@@ -139,7 +139,7 @@ LOG: smtp-response DEBUG
 : prepare-message ( body headers -- body' )
     [
         prepare-headers
-        " " ,
+        "" ,
         dup string? [ string-lines ] when %
     ] { } make ;
 
@@ -169,3 +169,15 @@ LOG: smtp-response DEBUG
 ! : cram-md5-auth ( key login  -- )
 !     "AUTH CRAM-MD5\r\n" get-ok 
 !     (cram-md5-auth) "\r\n" append get-ok ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: new-slots
+
+TUPLE: email from to subject body ;
+
+: <email> ( -- email ) email construct-empty ;
+
+: send ( email -- )
+  { email-body email-subject email-to email-from } get-slots
+  send-simple-message ;

extra/tools/browser/browser.factor

@@ -132,7 +132,7 @@ MEMO: all-vocabs-seq ( -- seq )
     require-all ;
 
 : load-everything ( -- )
-    try-everything drop ;
+    try-everything load-failures. ;
 
 : unrooted-child-vocabs ( prefix -- seq )
     dup empty? [ CHAR: . add ] unless

extra/ui/x11/x11.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend
+USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
-ui.clipboards ui.gadgets.worlds assocs kernel math namespaces
+ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
-opengl sequences strings x11.xlib x11.events x11.xim x11.glx
+namespaces opengl sequences strings x11.xlib x11.events x11.xim
-x11.clipboard x11.constants x11.windows io.utf8 combinators
+x11.glx x11.clipboard x11.constants x11.windows
-debugger system command-line ui.render math.vectors tuples
+io.encodings.utf8 combinators debugger system command-line
-opengl.gl threads ;
+ui.render math.vectors tuples opengl.gl threads ;
 IN: ui.x11
 
 TUPLE: x11-ui-backend ;

extra/unicode/breaks/breaks.factor

@@ -1,7 +1,7 @@
 USING: unicode.categories kernel math combinators splitting
 sequences math.parser io.files io assocs arrays namespaces
 combinators.lib assocs.lib math.ranges unicode.normalize
-unicode.syntax unicode.data compiler.units alien.syntax const ;
+unicode.syntax unicode.data compiler.units alien.syntax ;
 IN: unicode.breaks
 
 C-ENUM: Any L V T Extend Control CR LF graphemes ;

extra/unicode/data/data.factor

@@ -1,8 +1,16 @@
 USING: assocs math kernel sequences io.files hashtables
 quotations splitting arrays math.parser combinators.lib hash2
-byte-arrays words namespaces words compiler.units const ;
+byte-arrays words namespaces words compiler.units parser ;
 IN: unicode.data
 
+<<
+: VALUE:
+    CREATE dup reset-generic { f } clone [ first ] curry define ; parsing
+
+: set-value ( value word -- )
+    word-def first set-first ;
+>>
+
 ! Convenience functions
 : 1+* ( n/f _ -- n+1 )
     drop [ 1+ ] [ 0 ] if* ;

extra/x11/clipboard/clipboard.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax arrays kernel math
-namespaces sequences io.utf8 x11.xlib x11.constants ;
+namespaces sequences io.encodings.utf8 x11.xlib x11.constants ;
 IN: x11.clipboard
 
 ! This code was based on by McCLIM's Backends/CLX/port.lisp