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

core/alien/compiler/compiler.factor

@@ -326,7 +326,7 @@ M: alien-callback-error summary
     drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
 
 : callback-bottom ( node -- )
-    alien-callback-xt [ word-xt <alien> ] curry
+    alien-callback-xt [ word-xt drop <alien> ] curry
     recursive-state get infer-quot ;
 
 \ alien-callback [
@@ -398,7 +398,7 @@ TUPLE: callback-context ;
     callback-unwind %unwind ;
 
 : generate-callback ( node -- )
-    dup alien-callback-xt dup rot [
+    dup alien-callback-xt dup [
         init-templates
         %save-word-xt
         %prologue-later
@@ -407,7 +407,7 @@ TUPLE: callback-context ;
             dup wrap-callback-quot %alien-callback
             %callback-return
         ] with-stack-frame
-    ] generate-1 ;
+    ] with-generator ;
 
 M: alien-callback generate-node
     end-basic-block generate-callback iterate-next ;

core/alien/structs/structs-tests.factor

@@ -9,18 +9,20 @@ C-STRUCT: bar
 [ 36 ] [ "bar" heap-size ] unit-test
 [ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
 
-C-STRUCT: align-test
+! This was actually only correct on Windows/x86:
-    { "int" "x" }
-    { "double" "y" } ;
 
-[ 16 ] [ "align-test" heap-size ] unit-test
+! C-STRUCT: align-test
-
+!     { "int" "x" }
-cell 4 = [
+!     { "double" "y" } ;
-    C-STRUCT: one
+! 
-    { "long" "a" } { "double" "b" } { "int" "c" } ;
+! [ 16 ] [ "align-test" heap-size ] unit-test
-
+! 
-    [ 24 ] [ "one" heap-size ] unit-test
+! cell 4 = [
-] when
+!     C-STRUCT: one
+!     { "long" "a" } { "double" "b" } { "int" "c" } ;
+! 
+!     [ 24 ] [ "one" heap-size ] unit-test
+! ] when
 
 : MAX_FOOS 30 ;
 

core/assocs/assocs-docs.factor

@@ -59,6 +59,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
 { $subsection diff }
 { $subsection remove-all }
 { $subsection substitute }
+{ $subsection substitute-here }
 { $see-also key? } ;
 
 ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
@@ -266,12 +267,16 @@ HELP: remove-all
 { $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." }
 { $side-effects "assoc" } ;
 
-HELP: substitute
+HELP: substitute-here
-{ $values { "assoc" assoc } { "seq" "a mutable sequence" } }
+{ $values { "seq" "a mutable sequence" } { "assoc" assoc } }
-{ $description "Replaces elements of " { $snippet "seq" } " which appear in as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
+{ $description "Replaces elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
 { $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." }
 { $side-effects "seq" } ;
 
+HELP: substitute
+{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } }
+{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
+
 HELP: cache
 { $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
 { $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }

core/assocs/assocs.factor

@@ -124,8 +124,14 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : remove-all ( assoc seq -- subseq )
     swap [ key? not ] curry subset ;
 
-: substitute ( assoc seq -- )
+: (substitute)
-    swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ;
+    [ dupd at* [ nip ] [ drop ] if ] curry ; inline
+
+: substitute-here ( seq assoc -- )
+    (substitute) change-each ;
+
+: substitute ( seq assoc -- newseq )
+    (substitute) map ;
 
 : cache ( key assoc quot -- value )
     2over at [

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/bootstrap/stage2.factor

@@ -59,7 +59,7 @@ SYMBOL: bootstrap-time
 
     default-image-name "output-image" set-global
 
-    "math help compiler tools ui ui.tools io" "include" set-global
+    "math help handbook compiler tools ui ui.tools io" "include" set-global
     "" "exclude" set-global
 
     parse-command-line

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/compiler.factor

@@ -30,7 +30,7 @@ IN: compiler
 
 : compile-succeeded ( word -- effect dependencies )
     [
-        dup word-dataflow >r swap dup r> optimize generate
+        [ word-dataflow optimize ] keep dup generate
     ] computing-dependencies ;
 
 : compile-failed ( word error -- )

core/compiler/tests/simple.factor

@@ -227,3 +227,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
 [ 3 ] [ t single-combination-test-2 ] unit-test
 [ 3 ] [ 3 single-combination-test-2 ] unit-test
 [ f ] [ f single-combination-test-2 ] unit-test
+
+! Regression
+[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test

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/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 ;
+words definitions compiler.units io combinators ;
 IN: temporary
 
 ! Oops!
@@ -191,3 +191,18 @@ TUPLE: my-tuple ;
     2 1
     [ 2dup fixnum< [ >r die r> ] when ] compile-call
 ] unit-test
+
+! Regression
+: a-dummy drop "hi" print ;
+
+[ ] [
+    1 [
+        dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
+            drop - >fixnum {
+                [ a-dummy ]
+                [ a-dummy ]
+                [ a-dummy ]
+            } dispatch
+        ] [ 2drop no-case ] if
+    ] compile-call
+] unit-test

core/debugger/debugger-tests.factor

@@ -0,0 +1,4 @@
+IN: temporary
+USING: debugger kernel continuations tools.test ;
+
+[ ] [ [ drop ] [ error. ] recover ] unit-test

core/generator/fixup/fixup.factor

@@ -140,17 +140,19 @@ SYMBOL: literal-table
     V{ } clone relocation-table set
     V{ } clone label-table set ;
 
-: generate-labels ( -- labels )
+: resolve-labels ( labels -- labels' )
-    label-table get [
+    [
         first3 label-offset
         [ "Unresolved label" throw ] unless*
         3array
     ] map concat ;
 
-: fixup ( code -- relocation-table label-table code )
+: fixup ( code -- literals relocation labels code )
     [
         init-fixup
         dup stack-frame-size swap [ fixup* ] each drop
+
+        literal-table get >array
         relocation-table get >array
-        generate-labels
+        label-table get resolve-labels
     ] { } make ;

core/generator/generator-docs.factor

@@ -22,34 +22,35 @@ HELP: compiled
 { $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
 
 HELP: compiling-word
-{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;
+{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
 
 HELP: compiling-label
-{ $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
+{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
 
 HELP: compiled-stack-traces?
 { $values { "?" "a boolean" } }
 { $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
 
 HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
 
-HELP: init-generator
+HELP: begin-compiling
+{ $values { "word" word } { "label" word } }
 { $description "Prepares to generate machine code for a word." } ;
 
-HELP: generate-1
+HELP: with-generator
-{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
+{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
 { $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
 
 HELP: generate-node
 { $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
 { $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
 
 HELP: generate-nodes
 { $values { "node" "a dataflow node" } } 
 { $description "Recursively generate machine code for a dataflow graph." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
 
 HELP: generate
 { $values { "word" word } { "label" word } { "node" "a dataflow node" } }

core/generator/generator.factor

@@ -11,12 +11,6 @@ IN: generator
 SYMBOL: compile-queue
 SYMBOL: compiled
 
-: begin-compiling ( word -- )
-    f swap compiled get set-at ;
-
-: finish-compiling ( word literals relocation labels code -- )
-    4array swap compiled get set-at ;
-
 : queue-compile ( word -- )
     {
         { [ dup compiled get key? ] [ drop ] }
@@ -32,24 +26,31 @@ SYMBOL: compiling-word
 
 SYMBOL: compiling-label
 
+SYMBOL: compiling-loops
+
 ! Label of current word, after prologue, makes recursion faster
 SYMBOL: current-label-start
 
 : compiled-stack-traces? ( -- ? ) 36 getenv ;
 
-: init-generator ( -- )
+: begin-compiling ( word label -- )
+    H{ } clone compiling-loops set
+    compiling-label set
+    compiling-word set
     compiled-stack-traces?
-    compiling-word get  f ?
+    compiling-word get f ?
-    1vector literal-table set ;
+    1vector literal-table set
+    f compiling-word get compiled get set-at ;
 
-: generate-1 ( word label node quot -- )
+: finish-compiling ( literals relocation labels code -- )
-    pick begin-compiling [
+    4array compiling-label get compiled get set-at ;
-        roll compiling-word set
+
-        pick compiling-label set
+: with-generator ( node word label quot -- )
-        init-generator
+    [
-        call
+        >r begin-compiling r>
-        literal-table get >array
+        { } make fixup
-    ] { } make fixup finish-compiling ;
+        finish-compiling
+    ] with-scope ; inline
 
 GENERIC: generate-node ( node -- next )
 
@@ -62,12 +63,12 @@ GENERIC: generate-node ( node -- next )
     %prologue-later
     current-label-start define-label
     current-label-start resolve-label ;
-    
+
-: generate ( word label node -- )
+: generate ( node word label -- )
     [
         init-generate-nodes
         [ generate-nodes ] with-node-iterator
-    ] generate-1 ;
+    ] with-generator ;
 
 : word-dataflow ( word -- effect dataflow )
     [
@@ -82,25 +83,6 @@ GENERIC: generate-node ( node -- next )
 : if-intrinsics ( #call -- quot )
     node-param "if-intrinsics" word-prop ;
 
-DEFER: #terminal?
-
-PREDICATE: #merge #terminal-merge node-successor #terminal? ;
-
-PREDICATE: #values #terminal-values node-successor #terminal? ;
-
-PREDICATE: #call #terminal-call
-    dup node-successor #if?
-    over node-successor node-successor #terminal? and
-    swap if-intrinsics and ;
-
-UNION: #terminal
-    POSTPONE: f #return #terminal-values #terminal-merge ;
-
-: tail-call? ( -- ? )
-    node-stack get [
-        dup #terminal-call? swap node-successor #terminal? or
-    ] all? ;
-
 ! node
 M: node generate-node drop iterate-next ;
 
@@ -112,20 +94,34 @@ M: node generate-node drop iterate-next ;
 : generate-call ( label -- next )
     dup maybe-compile
     end-basic-block
-    tail-call? [
+    dup compiling-loops get at [
-        %jump f
+        %jump-label f
     ] [
-        0 frame-required
+        tail-call? [
-        %call
+            %jump f
-        iterate-next
+        ] [
-    ] if ;
+            0 frame-required
+            %call
+            iterate-next
+        ] if
+    ] ?if ;
 
 ! #label
 M: #label generate-node
     dup node-param generate-call >r
-    dup #label-word over node-param rot node-child generate
+    dup node-child over #label-word rot node-param generate
     r> ;
 
+! #loop
+: compiling-loop ( word -- )
+    <label> dup resolve-label swap compiling-loops get set-at ;
+
+M: #loop generate-node
+    end-basic-block
+    dup node-param compiling-loop
+    node-child generate-nodes
+    iterate-next ;
+
 ! #if
 : end-false-branch ( label -- )
     tail-call? [ %return drop ] [ %jump-label ] if ;
@@ -150,25 +146,18 @@ M: #if generate-node
 ! #dispatch
 : dispatch-branch ( node word -- label )
     gensym [
-        rot [
+        [
             copy-templates
             %save-dispatch-xt
             %prologue-later
             [ generate-nodes ] with-node-iterator
-        ] generate-1
+        ] with-generator
     ] keep ;
 
-: tail-dispatch? ( node -- ? )
-    #! Is the dispatch a jump to a tail call to a word?
-    dup #call? swap node-successor #return? and ;
-
 : dispatch-branches ( node -- )
     node-children [
-        dup tail-dispatch? [
+        compiling-word get dispatch-branch
-            node-param
+        %dispatch-label
-        ] [
-            compiling-word get dispatch-branch
-        ] if %dispatch-label
     ] each ;
 
 : generate-dispatch ( node -- )
@@ -182,10 +171,10 @@ M: #dispatch generate-node
         generate-dispatch iterate-next
     ] [
         compiling-word get gensym [
-            rot [
+            [
                 init-generate-nodes
                 generate-dispatch
-            ] generate-1
+            ] with-generator
         ] keep generate-call
     ] if ;
 
@@ -224,10 +213,11 @@ M: #dispatch generate-node
 : define-if-intrinsic ( word quot inputs -- )
     2array 1array define-if-intrinsics ;
 
-: do-if-intrinsic ( #call pair -- next )
+: do-if-intrinsic ( pair -- next )
-    <label> [ swap do-template ] keep
+    <label> [
-    >r node-successor r> generate-if
+        swap do-template
-    node-successor ;
+        node> node-successor dup >node
+    ] keep generate-if ;
 
 : find-intrinsic ( #call -- pair/f )
     intrinsics find-template ;
@@ -249,7 +239,7 @@ M: #call generate-node
         ] [
             node-param generate-call
         ] ?if
-    ] if* ;
+    ] ?if ;
 
 ! #call-label
 M: #call-label generate-node node-param generate-call ;
@@ -274,4 +264,7 @@ M: #r> generate-node
     iterate-next ;
 
 ! #return
-M: #return generate-node drop end-basic-block %return f ;
+M: #return generate-node
+    end-basic-block
+    node-param compiling-loops get key?
+    [ %return ] unless f ;

core/generator/registers/registers.factor

@@ -504,7 +504,7 @@ M: loc lazy-store
 : substitute-vregs ( values vregs -- )
     [ vreg-substitution ] 2map
     [ substitute-vreg? ] assoc-subset >hashtable
-    [ swap substitute ] curry each-phantom ;
+    [ substitute-here ] curry each-phantom ;
 
 : set-operand ( value var -- )
     >r dup constant? [ constant-value ] when r> set ;

core/generic/math/math.factor

@@ -58,16 +58,15 @@ TUPLE: no-math-method left right generic ;
         2drop object-method
     ] if ;
 
-: math-vtable* ( picker max quot -- quot )
+: math-vtable ( picker quot -- quot )
     [
-        rot , \ tag ,
+        >r
-        [ >r [ bootstrap-type>class ] map r> map % ] { } make ,
+        , \ tag ,
+        num-tags get [ bootstrap-type>class ]
+        r> compose map ,
         \ dispatch ,
     ] [ ] make ; inline
 
-: math-vtable ( picker quot -- quot )
-    num-tags get swap math-vtable* ; inline
-
 TUPLE: math-combination ;
 
 M: math-combination make-default-method

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-docs.factor

@@ -1,4 +1,5 @@
-USING: inference.dataflow help.syntax help.markup ;
+USING: help.syntax help.markup ;
+IN: inference.dataflow
 
 HELP: #return
 { $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } }

core/inference/dataflow/dataflow.factor

@@ -97,11 +97,13 @@ M: object flatten-curry , ;
 
 : node-child node-children first ;
 
-TUPLE: #label word ;
+TUPLE: #label word loop? ;
 
 : #label ( word label -- node )
     \ #label param-node [ set-#label-word ] keep ;
 
+PREDICATE: #label #loop #label-loop? ;
+
 TUPLE: #entry ;
 
 : #entry ( -- node ) \ #entry all-out-node ;
@@ -304,3 +306,19 @@ SYMBOL: node-stack
     node-children
     [ last-node ] map
     [ #terminate? not ] subset ;
+
+DEFER: #tail?
+
+PREDICATE: #merge #tail-merge node-successor #tail? ;
+
+PREDICATE: #values #tail-values node-successor #tail? ;
+
+UNION: #tail
+    POSTPONE: f #return #tail-values #tail-merge #terminate ;
+
+: tail-call? ( -- ? )
+    #! We don't consider calls which do non-local exits to be
+    #! tail calls, because this gives better error traces.
+    node-stack get [
+        node-successor dup #tail? swap #terminate? not and
+    ] all? ;

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

@@ -345,7 +345,7 @@ M: object infer-call
 \ <word> { object object } { word } <effect> set-primitive-effect
 \ <word> make-flushable
 
-\ word-xt { word } { integer } <effect> set-primitive-effect
+\ word-xt { word } { integer integer } <effect> set-primitive-effect
 \ word-xt make-flushable
 
 \ getenv { fixnum } { object } <effect> set-primitive-effect

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 growable strings io classes io.streams.c
+continuations ;
 IN: io.encodings
 
 TUPLE: encode-error ;
@@ -18,11 +19,77 @@ SYMBOL: begin
     over push 0 begin ;
 
 : push-replacement ( buf -- buf ch state )
-    UNICHAR: replacement-character decoded ;
+    CHAR: replacement-character decoded ;
 
 : 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-tests.factor

@@ -1,15 +1,15 @@
-USING: tools.test io.utf16 arrays unicode.syntax ;
+USING: tools.test io.utf16 arrays unicode ;
 
 [ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test
 [ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test
-[ { UNICHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test
-[ { UNICHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test
 
 [ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test
 
 [ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test
 [ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test
-[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test
-[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test
 
 [ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test

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 ;
+
+: 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 ;
+
+[ { CHAR: 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
+
+[ { CHAR: 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
@@ -38,10 +37,10 @@ GENERIC: optimize-node* ( node -- node/t changed? )
     over assoc-empty? [
         2drop
     ] [
-        2dup node-in-d substitute
+        2dup node-in-d swap substitute-here
-        2dup node-in-r substitute
+        2dup node-in-r swap substitute-here
-        2dup node-out-d substitute
+        2dup node-out-d swap substitute-here
-        node-out-r substitute
+        node-out-r swap substitute-here
     ] if ;
 
 : perform-substitutions ( node -- )
@@ -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,277 +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 ;
-
-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 ] }
-        { [ t ] [ inline-method ] }
-    } cond dup not ;

core/optimizer/control/control-tests.factor

@@ -0,0 +1,181 @@
+IN: temporary
+USING: tools.test optimizer.control combinators kernel
+sequences inference.dataflow math inference classes strings
+optimizer ;
+
+: label-is-loop? ( node word -- ? )
+    [
+        {
+            { [ over #label? not ] [ 2drop f ] }
+            { [ over #label-word over eq? not ] [ 2drop f ] }
+            { [ over #label-loop? not ] [ 2drop f ] }
+            { [ t ] [ 2drop t ] }
+        } cond
+    ] curry node-exists? ;
+
+: label-is-not-loop? ( node word -- ? )
+    [
+        {
+            { [ over #label? not ] [ 2drop f ] }
+            { [ over #label-word over eq? not ] [ 2drop f ] }
+            { [ over #label-loop? ] [ 2drop f ] }
+            { [ t ] [ 2drop t ] }
+        } cond
+    ] curry node-exists? ;
+
+: loop-test-1 ( a -- )
+    dup [ 1+ loop-test-1 ] [ drop ] if ; inline
+
+[ t ] [
+    [ loop-test-1 ] dataflow dup detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ loop-test-1 1 2 3 ] dataflow dup detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ [ loop-test-1 ] each ] dataflow dup detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ [ loop-test-1 ] each ] dataflow dup detect-loops
+    \ (each-integer) label-is-loop?
+] unit-test
+
+: loop-test-2 ( a -- )
+    dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
+
+[ t ] [
+    [ loop-test-2 ] dataflow dup detect-loops
+    \ loop-test-2 label-is-not-loop?
+] unit-test
+
+: loop-test-3 ( a -- )
+    dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
+
+[ t ] [
+    [ loop-test-3 ] dataflow dup detect-loops
+    \ loop-test-3 label-is-not-loop?
+] unit-test
+
+: loop-test-4 ( a -- )
+    dup [
+        loop-test-4
+    ] [
+        drop
+    ] if ; inline
+
+: find-label ( node -- label )
+    dup #label? [ node-successor find-label ] unless ;
+
+: test-loop-exits
+    dataflow dup detect-loops find-label
+    dup node-param swap
+    [ node-child find-tail find-loop-exits [ class ] map ] keep
+    #label-loop? ;
+
+[ { #values } t ] [
+    [ loop-test-4 ] test-loop-exits
+] unit-test
+
+: loop-test-5 ( a -- )
+    dup [
+        dup string? [
+            loop-test-5
+        ] [
+            drop
+        ] if
+    ] [
+        drop
+    ] if ; inline
+
+[ { #values #values } t ] [
+    [ loop-test-5 ] test-loop-exits
+] unit-test
+
+: loop-test-6 ( a -- )
+    dup [
+        dup string? [
+            loop-test-6
+        ] [
+            3 throw
+        ] if
+    ] [
+        drop
+    ] if ; inline
+
+[ { #values } t ] [
+    [ loop-test-6 ] test-loop-exits
+] unit-test
+
+[ f ] [
+    [ [ [ ] map ] map ] dataflow dup detect-loops
+    [ dup #label? swap #loop? not and ] node-exists?
+] unit-test
+
+: blah f ;
+
+DEFER: a
+
+: b ( -- )
+    blah [ b ] [ a ] if ; inline
+
+: a ( -- )
+    blah [ b ] [ a ] if ; inline
+
+[ t ] [
+    [ a ] dataflow dup detect-loops
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] dataflow dup detect-loops
+    \ b label-is-loop?
+] unit-test
+
+[ t ] [
+    [ b ] dataflow dup detect-loops
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] dataflow dup detect-loops
+    \ b label-is-loop?
+] unit-test
+
+DEFER: a'
+
+: b' ( -- )
+    blah [ b' b' ] [ a' ] if ; inline
+
+: a' ( -- )
+    blah [ b' ] [ a' ] if ; inline
+
+[ f ] [
+    [ a' ] dataflow dup detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ b' ] dataflow dup detect-loops
+    \ b' label-is-loop?
+] unit-test
+
+! I used to think this should be f, but doing this on pen and
+! paper almost convinced me that a loop conversion here is
+! sound. The loop analysis algorithm looks pretty solid -- its
+! a standard iterative dataflow problem after all -- so I'm
+! tempted to believe the computer here
+[ t ] [
+    [ b' ] dataflow dup detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ a' ] dataflow dup detect-loops
+    \ b' label-is-loop?
+] unit-test

core/optimizer/control/control.factor

@@ -0,0 +1,336 @@
+! 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 ;
+IN: optimizer.control
+
+! ! ! Rudimentary CFA
+
+! 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 which is
+! not a loop):
+!
+!
+!          #label A
+!             |
+!            #if ----> #merge ----> ... ----> #return
+!             |
+!       -------------
+!       |           |
+!      ...      #label B
+!                   |
+!                  #if -> ...
+!                   |
+!               ---------
+!               |       |
+!         #call-label A |
+!               |       |
+!           #values     |
+!                 #call-label B
+!                       |
+!                      ...
+
+! Mapping word => { node { nesting tail? }+ height }
+! We record all calls to a label, their control nesting and
+! whether it is a tail call or not
+SYMBOL: label-info
+
+GENERIC: collect-label-info* ( node -- )
+
+M: #label collect-label-info*
+    [ V{ } clone node-stack get length 3array ] keep
+    node-param label-info get set-at ;
+
+USE: prettyprint
+
+M: #call-label collect-label-info*
+    node-param label-info get at
+    node-stack get over third tail
+    [ [ #label? ] subset [ node-param ] map ] keep
+    [ node-successor #tail? ] all? 2array
+    swap second push ;
+
+M: node collect-label-info*
+    drop ;
+
+: collect-label-info ( node -- )
+    H{ } clone label-info set
+    [ collect-label-info* ] each-node ;
+
+! Mapping word => label
+SYMBOL: potential-loops
+
+: remove-non-tail-calls ( -- )
+    label-info get
+    [ nip second [ second ] all? ] assoc-subset
+    [ first ] assoc-map
+    potential-loops set ;
+
+: remove-non-loop-calls ( -- )
+    ! Boolean is set to t if something changed.
+    !  We recurse until a fixed point is reached.
+    f label-info get [
+        ! If label X is called from within a label Y that is
+        ! no longer a potential loop, then X is no longer a
+        ! potential loop either.
+        over potential-loops get key? [
+            second [ first ] map concat
+            potential-loops get [ key? ] curry all?
+            [ drop ] [ potential-loops get delete-at t or ] if
+        ] [ 2drop ] if
+    ] assoc-each [ remove-non-loop-calls ] when ;
+
+: detect-loops ( nodes -- )
+    [
+        collect-label-info
+        remove-non-tail-calls
+        remove-non-loop-calls
+        potential-loops get [
+            nip t swap set-#label-loop?
+        ] assoc-each
+    ] with-scope ;
+
+! ! ! 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
+
+! 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 #
+
+: 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 ;
+
+: 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 ;
+
+! 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 -> #return 1
+!         |
+!         -> #if -------> #merge (*) -> #return 2
+!             |           \-------------------/
+!     ----------------              |
+!     |              |              |
+!     A              B     unreacachable code needed to
+!     |              |         preserve invariants
+!  #values           |
+!     |          #call-label
+!  #merge (*)        |
+!     |              |
+!     C           #values
+!     |
+!  #return 1
+
+: find-tail ( node -- tail )
+    dup #terminate? [
+        dup node-successor #tail? [
+            node-successor find-tail
+        ] unless
+    ] unless ;
+
+: child-tails ( node -- seq )
+    node-children [ find-tail ] map ;
+
+GENERIC: add-loop-exit* ( label node -- )
+
+M: #branch add-loop-exit*
+    child-tails [ add-loop-exit* ] with each ;
+
+M: #call-label add-loop-exit*
+    tuck node-param eq? [ drop ] [ node-successor , ] if ;
+
+M: #terminate add-loop-exit*
+    2drop ;
+
+M: node add-loop-exit*
+    nip node-successor dup #terminate? [ drop ] [ , ] if ;
+
+: find-loop-exits ( label node -- seq )
+    [ add-loop-exit* ] { } make ;
+
+: 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 [
+            find-loop-exits only-one
+        ] [ 2drop f ] if
+    ] [ drop f ] if ;
+
+M: #loop optimize-node*
+    dup lift-loop-tail? dup [
+        last-node "values" set
+
+        dup node-successor "tail" set
+        dup node-successor last-node "return" set
+        dup node-child find-final-if node-successor "merge" set
+
+        ! #label -> #return
+        "return" get clone-node over set-node-successor
+        ! #merge -> C
+        "merge" get clone-node "tail" get over set-node-successor
+        ! #values -> #merge ->C
+        "values" get 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 namespaces ;
 IN: temporary
 
 [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@@ -301,3 +301,53 @@ 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
+
+! Make sure we don't lose
+GENERIC: generic-inline-test ( x -- y )
+M: integer generic-inline-test ;
+
+: generic-inline-test-1
+    1
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test ;
+
+[ { t f } ] [
+    \ generic-inline-test-1 word-def dataflow
+    [ optimize-1 , optimize-1 , drop ] { } make
+] unit-test

core/optimizer/optimizer.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces optimizer.backend optimizer.def-use
-optimizer.known-words optimizer.math inference.class ;
+optimizer.known-words optimizer.math optimizer.control
+optimizer.inlining inference.class ;
 IN: optimizer
 
 : optimize-1 ( node -- newnode ? )
@@ -11,6 +12,7 @@ IN: optimizer
         H{ } clone value-substitutions set
         dup compute-def-use
         kill-values
+        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

core/parser/parser-docs.factor

@@ -266,19 +266,10 @@ HELP: escape
 { $description "Converts from a single-character escape code and the corresponding character." }
 { $examples { $example "CHAR: n escape CHAR: \\n = ." "t" } } ;
 
-HELP: next-escape
-{ $values { "m" "an index into " { $snippet "str" } } { "str" string } { "n" "an index into " { $snippet "str" } } { "ch" "a character" } }
-{ $description "Helper word for " { $link parse-string } " which parses an escape sequence starting at the " { $snippet "m" } "th index of " { $snippet "str" } "." }
-{ $errors "Throws a " { $link bad-escape } " if the string contains an invalid escape sequence." } ;
-
-HELP: next-char
-{ $values { "m" "an index into " { $snippet "str" } } { "str" string } { "n" "an index into " { $snippet "str" } } { "ch" "a character" } }
-{ $description "Helper word for " { $link parse-string } " which parses a character starting at the " { $snippet "m" } "th index of " { $snippet "str" } "." } ;
-
 HELP: parse-string
 { $values { "str" "a new " { $link string } } }
 { $description "Parses the line until a quote (\"), interpreting escape codes along the way." }
-{ $errors "Throws an " { $link bad-escape } " if the string contains an invalid escape sequence." }
+{ $errors "Throws an error if the string contains an invalid escape sequence." }
 $parsing-note ;
 
 HELP: still-parsing?

core/parser/parser.factor

@@ -119,22 +119,43 @@ M: bad-escape summary drop "Bad escape code" ;
         { CHAR: \" CHAR: \" }
     } at [ bad-escape ] unless* ;
 
-: next-escape ( m str -- n ch )
+SYMBOL: name>char-hook
-    2dup nth CHAR: u =
-    [ >r 1+ dup 6 + tuck r> subseq hex> ]
-    [ over 1+ -rot nth escape ] if ;
 
-: next-char ( m str -- n ch )
+name>char-hook global [
-    2dup nth CHAR: \\ =
+    [ "Unicode support not available" throw ] or
-    [ >r 1+ r> next-escape ] [ over 1+ -rot nth ] if ;
+] change-at
 
-: (parse-string) ( m str -- n )
+: unicode-escape ( str -- ch str' )
-    2dup nth CHAR: " =
+    "{" ?head-slice [
-    [ drop 1+ ] [ [ next-char , ] keep (parse-string) ] if ;
+        CHAR: } over index cut-slice
+        >r >string name>char-hook get call r>
+        1 tail-slice
+    ] [
+        6 cut-slice >r hex> r>
+    ] if ;
+
+: next-escape ( str -- ch str' )
+    "u" ?head-slice [
+        unicode-escape
+    ] [
+        unclip-slice escape swap
+    ] if ;
+
+: (parse-string) ( str -- m )
+    dup [ "\"\\" member? ] find dup [
+        >r cut-slice >r % r> 1 tail-slice r>
+        dup CHAR: " = [
+            drop slice-from
+        ] [
+            drop next-escape >r , r> (parse-string)
+        ] if
+    ] [
+        "Unterminated string" throw
+    ] if ;
 
 : parse-string ( -- str )
     lexer get [
-        [ (parse-string) ] "" make swap
+        [ swap tail-slice (parse-string) ] "" make swap
     ] change-column ;
 
 TUPLE: parse-error file line col text ;

core/sequences/sequences.factor

@@ -257,7 +257,7 @@ INSTANCE: repetition immutable-sequence
 
 : check-copy ( src n dst -- )
     over 0 < [ bounds-error ] when
-    >r swap length + r> lengthen ;
+    >r swap length + r> lengthen ; inline
 
 PRIVATE>
 

core/syntax/syntax-docs.factor

@@ -100,13 +100,9 @@ ARTICLE: "escape" "Character escape codes"
     { { $snippet "\\0" } "a null byte (ASCII 0)" }
     { { $snippet "\\e" } "escape (ASCII 27)" }
     { { $snippet "\\\"" } { $snippet "\"" } }
-}
+    { { $snippet "\\u" { $emphasis "xxxxxx" } } { "The Unicode code point with hexadecimal number " { $snippet { $emphasis "xxxxxx" } } } }
-"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a six-digit hexadecimal number. That is, the following two expressions are equivalent:"
+    { { $snippet "\\u{" { $emphasis "name" } "}" } { "The Unicode code point named " { $snippet { $emphasis "name" } } } }
-{ $code
+} ;
-    "CHAR: \\u000078"
-    "78"
-}
-"While not useful for single characters, this syntax is also permitted inside strings." ;
 
 ARTICLE: "syntax-strings" "Character and string syntax"
 "Factor has no distinct character type, however Unicode character value integers can be read by specifying a literal character, or an escaped representation thereof."
@@ -412,8 +408,17 @@ HELP: IN:
 
 HELP: CHAR:
 { $syntax "CHAR: token" }
-{ $values { "token" "a literal character or escape code" } }
+{ $values { "token" "a literal character, escape code, or Unicode character name" } }
-{ $description "Adds the Unicode code point of the character represented by the token to the parse tree." } ;
+{ $description "Adds a Unicode code point to the parse tree." }
+{ $examples
+    { $code
+        "CHAR: x"
+        "CHAR: \\u000032"
+        "CHAR: \\u{exclamation-mark}"
+        "CHAR: exclamation-mark"
+        "CHAR: ugaritic-letter-samka"
+    }
+} ;
 
 HELP: "
 { $syntax "\"string...\"" }

core/syntax/syntax.factor

@@ -5,7 +5,8 @@ byte-vectors definitions generic hashtables kernel math
 namespaces parser sequences strings sbufs vectors words
 quotations io assocs splitting tuples generic.standard
 generic.math classes io.files vocabs float-arrays float-vectors
-classes.union classes.mixin classes.predicate compiler.units ;
+classes.union classes.mixin classes.predicate compiler.units
+combinators ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -56,7 +57,14 @@ IN: bootstrap.syntax
     "f" [ f parsed ] define-syntax
     "t" "syntax" lookup define-symbol
 
-    "CHAR:" [ 0 scan next-char nip parsed ] define-syntax
+    "CHAR:" [
+        scan {
+            { [ dup length 1 = ] [ first ] }
+            { [ "\\" ?head ] [ next-escape drop ] }
+            { [ t ] [ name>char-hook get call ] }
+        } cond parsed
+    ] define-syntax
+
     "\"" [ parse-string parsed ] define-syntax
 
     "SBUF\"" [

core/threads/threads-docs.factor

@@ -9,6 +9,7 @@ $nl
 { $subsection in-thread }
 { $subsection yield }
 { $subsection sleep }
+"Threads stop either when the quotation given to " { $link in-thread } " returns, or when the following word is called:"
 { $subsection stop }
 "Continuations can be added to the run queue directly:"
 { $subsection schedule-thread }
@@ -21,7 +22,8 @@ ABOUT: "threads"
 
 HELP: run-queue
 { $values { "queue" dlist } }
-{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } 
" and dequeued with " { $link pop-back } "." } ;
+{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } 
+" and dequeued with " { $link pop-back } "." } ;
 
 HELP: schedule-thread
 { $values { "continuation" "a continuation reified by " { $link callcc0 } } }

core/vocabs/loader/loader.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces splitting sequences io.files kernel assocs
+USING: namespaces sequences io.files kernel assocs words vocabs
-words vocabs definitions parser continuations inspector debugger
+definitions parser continuations inspector debugger io io.styles
-io io.styles io.streams.lines hashtables sorting prettyprint
+io.streams.lines hashtables sorting prettyprint source-files
-source-files arrays combinators strings system math.parser
+arrays combinators strings system math.parser compiler.errors
-compiler.errors ;
+splitting ;
 IN: vocabs.loader
 
 SYMBOL: vocab-roots
@@ -16,7 +16,7 @@ V{
 } clone vocab-roots set-global
 
 : vocab-dir ( vocab -- dir )
-    vocab-name "." split "/" join ;
+    vocab-name { { CHAR: . CHAR: / } } substitute ;
 
 : vocab-dir+ ( vocab str/f -- path )
     >r vocab-name "." split r>

core/words/words-docs.factor

@@ -245,8 +245,8 @@ HELP: remove-word-prop
 { $description "Removes a word property, so future lookups will output " { $link f } " until it is set again. Word property names are conventionally strings." }
 { $side-effects "word" } ;
 
-HELP: word-xt
+HELP: word-xt ( word -- start end )
-{ $values { "word" word } { "xt" "an execution token integer" } }
+{ $values { "word" word } { "start" "the word's start address" } { "end" "the word's end address" } }
 { $description "Outputs the machine code address of the word's definition." } ;
 
 HELP: define-symbol

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/bootstrap2/bootstrap2.factor

@@ -1,14 +0,0 @@
-USING: io.files io.launcher system bootstrap.image
-namespaces sequences kernel ;
-IN: benchmark.bootstrap2
-
-: bootstrap-benchmark
-    "." resource-path cd
-    [
-        vm ,
-        "-i=" my-boot-image-name append ,
-        "-output-image=foo.image" ,
-        "-no-user-init" ,
-    ] { } make try-process ;
-
-MAIN: bootstrap-benchmark

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/bootstrap/handbook/handbook.factor

@@ -0,0 +1,3 @@
+USING: vocabs.loader vocabs kernel ;
+
+"bootstrap.help" vocab [ "help.handbook" require ] when

extra/bootstrap/help/help.factor

@@ -14,8 +14,6 @@ IN: bootstrap.help
         [ vocab-root ] subset
         [ vocab-source-loaded? ] subset
         [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
-    ] with-variable
+    ] with-variable ;
-
-    "help.handbook" require ;
 
 load-help

extra/bootstrap/tools/tools.factor

@@ -4,10 +4,11 @@ USING: vocabs.loader sequences ;
     "bootstrap.image"
     "tools.annotations"
     "tools.crossref"
-    ! "tools.deploy"
+    "tools.deploy"
     "tools.memory"
     "tools.profiler"
     "tools.test"
     "tools.time"
+    "tools.disassembler"
     "editors"
 } [ require ] each

extra/builder/builder.factor

@@ -3,71 +3,43 @@ 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 ;
+       combinators.cleave benchmark
+       classes strings quotations words parser-combinators new-slots accessors
+       assocs.lib smtp builder.util ;
 
 IN: builder
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: runtime ( quot -- time ) benchmark nip ;
+SYMBOL: builds-dir
+
+: builds ( -- path )
+  builds-dir get
+  home "/builds" append
+  or ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOL: builder-recipients
+: prepare-build-machine ( -- )
-
+  builds make-directory
-: host-name* ( -- name ) host-name "." split first ;
+  builds cd
-
+  { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
-: 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 ;
+: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
 
-: 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 ( -- )
   datestamp >stamp
-  "/builds" cd
+  builds cd
   stamp> make-directory
   stamp> cd ;
 
@@ -80,57 +52,59 @@ 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+ }
-   }
-  >hashtable ;
 
-: 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) ( -- )
 
+  builds-check  
+
+  build-status off
+
   enter-build-dir
 
   "report" [
 
     "Build machine:   " write host-name print
-    "Build directory: " write cwd       print
+    "CPU:             " write cpu       print
+    "OS:              " write os        print
+    "Build directory: " write cwd       print nl
 
     git-clone [ "git clone failed" print ] run-or-bail
 
@@ -142,7 +116,7 @@ SYMBOL: build-status
 
     make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
 
-    [ my-arch download-image ] [ "Image download error" print throw ] recover
+    [ retrieve-image ] [ "Image download error" print throw ] recover
 
     bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
 
@@ -152,20 +126,50 @@ SYMBOL: build-status
 
     "Boot time: " write "../boot-time" eval-file milli-seconds>time print
     "Load time: " write "../load-time" eval-file milli-seconds>time print
-    "Test time: " write "../test-time" eval-file milli-seconds>time print
+    "Test time: " write "../test-time" eval-file milli-seconds>time print nl
 
     "Did not pass load-everything: " print "../load-everything-vocabs" cat
     "Did not pass test-all: "        print "../test-all-vocabs"        cat
 
-  ] with-file-out ;
+    "Benchmarks: " print
+    "../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
 
-: build ( -- )
+  ] with-file-out
-  [ (build) ] [ drop ] recover
+
-  "report" "../report" email-file ;
+  build-status on ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: minutes>ms ( min -- ms ) 60 * 1000 * ;
+SYMBOL: builder-from
+
+SYMBOL: builder-recipients
+
+: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
+
+: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
+
+: send-builder-email ( -- )
+  <email>
+    builder-from get        >>from
+    builder-recipients get  >>to
+    subject                 >>subject
+    "../report" file>string >>body
+  send ;
+
+: build ( -- )
+  [ (build) ] [ drop ] recover
+  [ send-builder-email ] [ drop "not sending mail" . ] recover ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull ( -- desc )
+  {
+    "git"
+    "pull"
+    "--no-summary"
+    "git://factorcode.org/git/factor.git"
+    "master"
+  } ;
 
 : updates-available? ( -- ? )
   git-id
@@ -174,8 +178,9 @@ SYMBOL: build-status
   = not ;
 
 : build-loop ( -- )
+  builds-check
   [
-    "/builds/factor" cd
+    builds "/factor" append cd
     updates-available?
       [ build ]
     when

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 ;
+       bootstrap.stage2 benchmark builder.util ;
 
 IN: builder.test
 
@@ -16,9 +16,12 @@ IN: builder.test
 : do-tests ( -- )
   run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
 
+: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-out ;
+
 : do-all ( -- )
   bootstrap-time get   "../boot-time" [ . ] with-file-out
   [ do-load  ] runtime "../load-time" [ . ] with-file-out
-  [ do-tests ] runtime "../test-time" [ . ] with-file-out ;
+  [ do-tests ] runtime "../test-time" [ . ] with-file-out
+  do-benchmarks ;
 
 MAIN: do-all

extra/builder/util/util.factor

@@ -0,0 +1,86 @@
+
+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-contents eval ;
+
+: cat ( file -- ) file-contents print ;
+
+: run-or-bail ( desc quot -- )
+  [ [ try-process ] curry   ]
+  [ [ throw       ] compose ]
+  bi*
+  recover ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: bootstrap.image bootstrap.image.download io.streams.null ;
+
+: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ;

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/db/db.factor

@@ -1,32 +1,29 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes continuations kernel math
-namespaces sequences sequences.lib tuples words ;
+namespaces sequences sequences.lib tuples words strings ;
 IN: db
 
-TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
+TUPLE: db handle insert-statements update-statements delete-statements ;
 : <db> ( handle -- obj )
-    H{ } clone
+    H{ } clone H{ } clone H{ } clone
-    H{ } clone
-    H{ } clone
-    H{ } clone
     db construct-boa ;
 
 GENERIC: db-open ( db -- )
 HOOK: db-close db ( handle -- )
 
-: dispose-statements [ dispose drop ] assoc-each ;
+: dispose-statements ( seq -- )
+    [ dispose drop ] assoc-each ;
 
 : dispose-db ( db -- ) 
     dup db [
         dup db-insert-statements dispose-statements
         dup db-update-statements dispose-statements
         dup db-delete-statements dispose-statements
-        dup db-select-statements dispose-statements
         db-handle db-close
     ] with-variable ;
 
-TUPLE: statement sql params handle bound? ;
+TUPLE: statement sql params handle bound? slot-names ;
 TUPLE: simple-statement ;
 TUPLE: prepared-statement ;
 
@@ -35,7 +32,17 @@ HOOK: <prepared-statement> db ( str -- statement )
 GENERIC: prepare-statement ( statement -- )
 GENERIC: bind-statement* ( obj statement -- )
 GENERIC: reset-statement ( statement -- )
-GENERIC: execute-statement ( statement -- )
+GENERIC: insert-statement ( statement -- id )
+
+TUPLE: result-set sql params handle n max ;
+GENERIC: query-results ( query -- result-set )
+GENERIC: #rows ( result-set -- n )
+GENERIC: #columns ( result-set -- n )
+GENERIC# row-column 1 ( result-set n -- obj )
+GENERIC: advance-row ( result-set -- )
+GENERIC: more-rows? ( result-set -- ? )
+
+: execute-statement ( statement -- ) query-results dispose ;
 
 : bind-statement ( obj statement -- )
     dup statement-bound? [ dup reset-statement ] when
@@ -43,19 +50,9 @@ GENERIC: execute-statement ( statement -- )
     [ set-statement-params ] keep
     t swap set-statement-bound? ;
 
-TUPLE: result-set sql params handle n max ;
-
-GENERIC: query-results ( query -- result-set )
-GENERIC: #rows ( result-set -- n )
-GENERIC: #columns ( result-set -- n )
-GENERIC# row-column 1 ( result-set n -- obj )
-GENERIC: advance-row ( result-set -- ? )
-
-HOOK: last-id db ( -- id )
-
 : init-result-set ( result-set -- )
     dup #rows over set-result-set-max
-    -1 swap set-result-set-n ;
+    0 swap set-result-set-n ;
 
 : <result-set> ( query handle tuple -- result-set )
     >r >r { statement-sql statement-params } get-slots r>
@@ -69,10 +66,10 @@ HOOK: last-id db ( -- id )
     dup #columns [ row-column ] with map ;
 
 : query-each ( statement quot -- )
-    over advance-row [
+    over more-rows? [
-        2drop
+        [ call ] 2keep over advance-row query-each
     ] [
-        [ call ] 2keep query-each
+        2drop
     ] if ; inline
 
 : query-map ( statement quot -- seq )
@@ -93,11 +90,6 @@ HOOK: last-id db ( -- id )
 : do-bound-command ( obj query -- )
     [ bind-statement ] keep execute-statement ;
 
-: sql-query ( sql -- rows )
-    <simple-statement> [ do-query ] with-disposal ;
-
-: sql-command ( sql -- )
-    <simple-statement> [ execute-statement ] with-disposal ;
 
 SYMBOL: in-transaction
 HOOK: begin-transaction db ( -- )
@@ -111,3 +103,15 @@ HOOK: rollback-transaction db ( -- )
         begin-transaction
         [ ] [ rollback-transaction ] cleanup commit-transaction
     ] with-variable ;
+
+: sql-query ( sql -- rows )
+    <simple-statement> [ do-query ] with-disposal ;
+
+: sql-command ( sql -- )
+    dup string? [
+        <simple-statement> [ execute-statement ] with-disposal
+    ] [
+        ! [
+            [ sql-command ] each
+        ! ] with-transaction
+    ] if ;

extra/db/postgresql/ffi/ffi.factor

@@ -50,6 +50,8 @@ IN: db.postgresql.ffi
 : PQERRORS_DEFAULT                  HEX: 1 ; inline
 : PQERRORS_VERBOSE                  HEX: 2 ; inline
 
+: InvalidOid 0 ; inline
+
 TYPEDEF: int size_t
 TYPEDEF: int ConnStatusType
 TYPEDEF: int ExecStatusType 

extra/db/postgresql/lib/lib.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays continuations db io kernel math namespaces
-quotations sequences db.postgresql.ffi alien alien.c-types ;
+quotations sequences db.postgresql.ffi alien alien.c-types
+db.types ;
 IN: db.postgresql.lib
 
 : postgresql-result-error-message ( res -- str/f )
@@ -37,7 +38,8 @@ IN: db.postgresql.lib
     >r db get db-handle r>
     [ statement-sql ] keep
     [ statement-params length f ] keep
-    statement-params [ malloc-char-string ] map >c-void*-array
+    statement-params
+    [ first number>string* malloc-char-string ] map >c-void*-array
     f f 0 PQexecParams
     dup postgresql-result-ok? [
         dup postgresql-result-error-message swap PQclear throw

extra/db/postgresql/postgresql-tests.factor

@@ -2,7 +2,7 @@
 ! Set username and password in  the 'connect' word.
 
 USING: kernel db.postgresql alien continuations io prettyprint
-sequences namespaces tools.test db ;
+sequences namespaces tools.test db db.types ;
 IN: temporary
 
 IN: scratchpad
@@ -40,13 +40,13 @@ IN: temporary
     test-db [
         "select * from person where name = $1 and country = $2"
         <simple-statement> [
-            { "Jane" "New Zealand" }
+            { { "Jane" TEXT } { "New Zealand" TEXT } }
             over do-bound-query
 
             { { "Jane" "New Zealand" } } =
             [ "test fails" throw ] unless
 
-            { "John" "America" }
+            { { "John" TEXT } { "America" TEXT } }
             swap do-bound-query
         ] with-disposal
     ] with-db

extra/db/postgresql/postgresql.factor

@@ -1,8 +1,10 @@
 ! Copyright (C) 2007, 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs alien alien.syntax continuations io
-kernel math namespaces prettyprint quotations
+kernel math math.parser namespaces prettyprint quotations
-sequences debugger db db.postgresql.lib db.postgresql.ffi ;
+sequences debugger db db.postgresql.lib db.postgresql.ffi
+db.tuples db.types tools.annotations math.ranges
+combinators ;
 IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@@ -51,11 +53,19 @@ M: postgresql-result-set #columns ( result-set -- n )
 M: postgresql-result-set row-column ( result-set n -- obj )
     >r dup result-set-handle swap result-set-n r> PQgetvalue ;
 
-M: postgresql-statement execute-statement ( statement -- )
+M: postgresql-result-set row-column-typed ( result-set n type -- obj )
-    query-results dispose ;
+    >r row-column r> sql-type>factor-type ;
 
-: increment-n ( result-set -- n )
+M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
-    dup result-set-n 1+ dup rot set-result-set-n ;
+    {
+        { INTEGER [ string>number ] }
+        { BIG_INTEGER [ string>number ] }
+        { DOUBLE [ string>number ] }
+        [ drop ]
+    } case ;
+
+M: postgresql-statement insert-statement ( statement -- id )
+    query-results [ 0 row-column ] with-disposal string>number ;
 
 M: postgresql-statement query-results ( query -- result-set )
     dup statement-params [
@@ -67,8 +77,11 @@ M: postgresql-statement query-results ( query -- result-set )
     postgresql-result-set <result-set>
     dup init-result-set ;
 
-M: postgresql-result-set advance-row ( result-set -- ? )
+M: postgresql-result-set advance-row ( result-set -- )
-    dup increment-n swap result-set-max >= ;
+    dup result-set-n 1+ swap set-result-set-n ;
+
+M: postgresql-result-set more-rows? ( result-set -- ? )
+    dup result-set-n swap result-set-max < ;
 
 M: postgresql-statement dispose ( query -- )
     dup statement-handle PQclear
@@ -103,3 +116,154 @@ M: postgresql-db commit-transaction ( -- )
 
 M: postgresql-db rollback-transaction ( -- )
     "ROLLBACK" sql-command ;
+
+: postgresql-type-hash* ( -- assoc )
+    H{
+        { SERIAL "serial" }
+    } ;
+
+: postgresql-type-hash ( -- assoc )
+    H{
+        { INTEGER "integer" }
+        { SERIAL "integer" }
+        { TEXT "text" }
+        { VARCHAR "varchar" }
+        { DOUBLE "real" }
+    } ;
+
+: enquote ( str -- newstr ) "(" swap ")" 3append ;
+
+: postgresql-type ( str n/str  -- newstr )
+    " " swap number>string* enquote 3append ;
+
+: >sql-type* ( obj -- str )
+    dup pair? [
+        first2 >r >sql-type* r> postgresql-type
+    ] [
+        dup postgresql-type-hash* at* [
+            nip
+        ] [
+            drop >sql-type
+        ] if
+    ] if ;
+
+M: postgresql-db >sql-type ( hash obj -- str )
+    dup pair? [
+        first2 >r >sql-type r> postgresql-type
+    ]  [
+        postgresql-type-hash at* [
+            no-sql-type
+        ] unless
+    ] if ;
+
+: insert-function ( columns table -- sql )
+    [
+        >r remove-id r>
+        "create function add_" % dup %
+        "(" %
+        over [ "," % ]
+        [ third dup array? [ first ] when >sql-type % ] interleave
+        ")" %
+        " returns bigint as '" %
+
+        2dup "insert into " %
+        %
+        "(" %
+        dup [ ", " % ] [ second % ] interleave
+        ") " %
+        " values (" %
+        length [1,b] [ ", " % ] [ "$" % # ] interleave
+        "); " %
+
+        "select currval(''" % % "_id_seq'');' language sql;" %
+        drop
+    ] "" make ;
+
+: drop-function ( columns table -- sql )
+    [
+        >r remove-id r>
+        "drop function add_" % %
+        "(" %
+        [ "," % ] [ third >sql-type % ] interleave
+        ")" %
+    ] "" make ;
+
+M: postgresql-db create-sql ( columns table -- seq )
+    [
+        [
+            2dup
+            "create table " % %
+            " (" % [ ", " % ] [
+                dup second % " " %
+                dup third >sql-type* % " " %
+                sql-modifiers " " join %
+            ] interleave "); " %
+        ] "" make ,
+
+        over native-id? [ insert-function , ] [ 2drop ] if
+    ] { } make ;
+
+M: postgresql-db drop-sql ( columns table -- seq )
+    [
+        [
+            dup "drop table " % % ";" %
+        ] "" make ,
+        over native-id? [ drop-function , ] [ 2drop ] if
+    ] { } make ;
+
+M: postgresql-db insert-sql* ( columns table -- slot-names sql )
+    [
+        "select add_" % %
+        "(" %
+        length [1,b] [ ", " % ] [ "$" % # ] interleave
+        ")" %
+    ] "" make ;
+
+M: postgresql-db update-sql* ( columns table -- slot-names sql )
+    [
+        "update " %
+        %
+        " set " %
+        dup remove-id
+        dup length [1,b] swap 2array flip
+        [ ", " % ] [ first2 second % " = $" % # ] interleave
+        " where " %
+        [ primary-key? ] find nip second dup % " = $" % length 2 + #
+    ] "" make ;
+
+M: postgresql-db delete-sql* ( columns table -- slot-names sql )
+    [
+        "delete from " %
+        %
+        " where " %
+        first second % " = $1" %
+    ] "" make ;
+
+M: postgresql-db select-sql ( columns table -- slot-names sql )
+    drop ;
+
+M: postgresql-db tuple>params ( columns tuple -- obj )
+    [ >r dup third swap first r> get-slot-named swap ]
+    curry { } map>assoc ;
+    
+: postgresql-db-modifiers ( -- hashtable )
+    H{
+        { +native-id+ "not null primary key" }
+        { +assigned-id+ "primary key" }
+        { +autoincrement+ "autoincrement" }
+        { +unique+ "unique" }
+        { +default+ "default" }
+        { +null+ "null" }
+        { +not-null+ "not null" }
+    } ;
+
+M: postgresql-db sql-modifiers* ( modifiers -- str )
+    postgresql-db-modifiers swap [
+        dup array? [
+            first2
+            >r swap at r> number>string*
+            " " swap 3append
+        ] [
+            swap at
+        ] if
+    ] with map [ ] subset ;

extra/db/sqlite/ffi/ffi.factor

@@ -108,7 +108,7 @@ LIBRARY: sqlite
 FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
 FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
 FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
-FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
 FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
 FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
 FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
@@ -125,6 +125,8 @@ FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;

extra/db/sqlite/lib/lib.factor

@@ -30,7 +30,7 @@ IN: db.sqlite.lib
 
 : sqlite-prepare ( db sql -- handle )
     dup length "void*" <c-object> "void*" <c-object>
-    [ sqlite3_prepare_v2 sqlite-check-result ] 2keep
+    [ sqlite3_prepare sqlite-check-result ] 2keep
     drop *void* ;
 
 : sqlite-bind-parameter-index ( handle name -- index )
@@ -74,10 +74,11 @@ IN: db.sqlite.lib
     dup array? [ first ] when
     {
         { INTEGER [ sqlite-bind-int-by-name ] }
-        { BIG_INTEGER [ sqlite-bind-int-by-name ] }
+        { BIG_INTEGER [ sqlite-bind-int64-by-name ] }
         { TEXT [ sqlite-bind-text-by-name ] }
         { VARCHAR [ sqlite-bind-text-by-name ] }
         { DOUBLE [ sqlite-bind-double-by-name ] }
+        { SERIAL [ sqlite-bind-int-by-name ] }
         ! { NULL [ sqlite-bind-null-by-name ] }
         [ no-sql-type ]
     } case ;
@@ -95,17 +96,25 @@ IN: db.sqlite.lib
 : sqlite-column ( handle index -- string )
     sqlite3_column_text ;
 
+: sqlite-column-typed ( handle index type -- obj )
+    {
+        { INTEGER [ sqlite3_column_int ] }
+        { BIG_INTEGER [ sqlite3_column_int64 ] }
+        { TEXT [ sqlite3_column_text ] }
+        { DOUBLE [ sqlite3_column_double ] }
+    } case ;
+
 ! TODO
 : sqlite-row ( handle -- seq )
     dup sqlite-#columns [ sqlite-column ] with map ;
 
-: step-complete? ( step-result -- bool )
+: sqlite-step-has-more-rows? ( step-result -- bool )
     dup SQLITE_ROW =  [
-        drop f
+        drop t
     ] [
         dup SQLITE_DONE =
-        [ drop ] [ sqlite-check-result ] if t
+        [ drop ] [ sqlite-check-result ] if f
     ] if ;
 
 : sqlite-next ( prepared -- ? )
-    sqlite3_step step-complete? ;
+    sqlite3_step sqlite-step-has-more-rows? ;

extra/db/sqlite/sqlite.factor

@@ -25,9 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
 TUPLE: sqlite-statement ;
 C: <sqlite-statement> sqlite-statement
 
-TUPLE: sqlite-result-set ;
+TUPLE: sqlite-result-set has-more? ;
-: <sqlite-result-set> ( query -- sqlite-result-set )
-    dup statement-handle sqlite-result-set <result-set> ;
 
 M: sqlite-db <simple-statement> ( str -- obj )
     <prepared-statement> ;
@@ -52,8 +50,12 @@ M: sqlite-statement bind-statement* ( triples statement -- )
 M: sqlite-statement reset-statement ( statement -- )
     statement-handle sqlite-reset ;
 
-M: sqlite-statement execute-statement ( statement -- )
+: last-insert-id ( -- id )
-    statement-handle sqlite-next drop ;
+    db get db-handle sqlite3_last_insert_rowid
+    dup zero? [ "last-id failed" throw ] when ;
+
+M: sqlite-statement insert-statement ( statement -- id )
+    execute-statement last-insert-id ;
 
 M: sqlite-result-set #columns ( result-set -- n )
     result-set-handle sqlite-#columns ;
@@ -61,11 +63,19 @@ M: sqlite-result-set #columns ( result-set -- n )
 M: sqlite-result-set row-column ( result-set n -- obj )
     >r result-set-handle r> sqlite-column ;
 
-M: sqlite-result-set advance-row ( result-set -- handle ? )
+M: sqlite-result-set row-column-typed ( result-set n type -- obj )
-    result-set-handle sqlite-next ;
+    >r result-set-handle r> sqlite-column-typed ;
+
+M: sqlite-result-set advance-row ( result-set -- )
+    [ result-set-handle sqlite-next ] keep
+    set-sqlite-result-set-has-more? ;
+
+M: sqlite-result-set more-rows? ( result-set -- ? )
+    sqlite-result-set-has-more? ;
 
 M: sqlite-statement query-results ( query -- result-set )
-    dup statement-handle sqlite-result-set <result-set> ;
+    dup statement-handle sqlite-result-set <result-set>
+    dup advance-row ;
 
 M: sqlite-db begin-transaction ( -- )
     "BEGIN" sql-command ;
@@ -86,9 +96,10 @@ M: sqlite-db create-sql ( columns table -- sql )
         ] interleave ")" %
     ] "" make ;
 
-M: sqlite-db drop-sql ( table -- sql )
+M: sqlite-db drop-sql ( columns table -- sql )
     [
         "drop table " % %
+        drop
     ] "" make ;
 
 M: sqlite-db insert-sql* ( columns table -- sql )
@@ -103,6 +114,10 @@ M: sqlite-db insert-sql* ( columns table -- sql )
         ")" %
     ] "" make ;
 
+: where-primary-key% ( columns -- )
+    " where " %
+    [ primary-key? ] find nip second dup % " = :" % % ;
+
 M: sqlite-db update-sql* ( columns table -- sql )
     [
         "update " %
@@ -110,8 +125,7 @@ M: sqlite-db update-sql* ( columns table -- sql )
         " set " %
         dup remove-id
         [ ", " % ] [ second dup % " = :" % % ] interleave
-        " where " %
+        where-primary-key%
-        [ primary-key? ] find nip second dup % " = :" % %
     ] "" make ;
 
 M: sqlite-db delete-sql* ( columns table -- sql )
@@ -122,13 +136,18 @@ M: sqlite-db delete-sql* ( columns table -- sql )
         first second dup % " = :" % %
     ] "" make ;
 
-M: sqlite-db select-sql* ( columns table -- sql )
+: select-interval ( interval name -- )
+    ;
+
+: select-sequence ( seq name -- )
+    ;
+
+M: sqlite-db select-sql ( columns table -- sql )
     [
         "select ROWID, " %
-        swap [ ", " % ] [ second % ] interleave
+        over [ ", " % ] [ second % ] interleave
-        " from " %
+        " from " % %
-        %
+        " where " %
-        " where ROWID = :ID" %
     ] "" make ;
 
 M: sqlite-db tuple>params ( columns tuple -- obj )
@@ -137,10 +156,6 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
         dupd >r first r> get-slot-named swap
         third 3array
     ] curry map ;
-    
-M: sqlite-db last-id ( -- id )
-    db get db-handle sqlite3_last_insert_rowid ;
-
 
 : sqlite-db-modifiers ( -- hashtable )
     H{
@@ -167,6 +182,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str )
 : sqlite-type-hash ( -- assoc )
     H{
         { INTEGER "integer" }
+        { SERIAL "integer" }
         { TEXT "text" }
         { VARCHAR "text" }
         { DOUBLE "real" }
@@ -182,4 +198,3 @@ M: sqlite-db >sql-type ( obj -- str )
 ! HOOK: get-column-value ( n result-set type -- )
 ! M: sqlite get-column-value { { "TEXT" get-text-column } { 
 ! "INTEGER" get-integer-column } ... } case ;
-

extra/db/tuples/tuples-tests.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files kernel tools.test db db.sqlite db.tuples
-db.types continuations namespaces ;
+db.types continuations namespaces db.postgresql math ;
+! tools.time ;
 IN: temporary
 
 TUPLE: person the-id the-name the-number real ;
-: <person> ( name age -- person )
+: <person> ( name age real -- person )
     {
         set-person-the-name
         set-person-the-number
@@ -29,21 +30,22 @@ SYMBOL: the-person
 
     [ ] [ the-person get update-tuple ] unit-test
 
-    [ ] [ the-person get delete-tuple ] unit-test ;
+    [ ] [ the-person get delete-tuple ] unit-test
+    ; ! 1 [ ] [ person drop-table ] unit-test ;
 
 : test-sqlite ( -- )
     "tuples-test.db" resource-path <sqlite-db> [
         test-tuples
     ] with-db ;
 
-! : test-postgres ( -- )
+: test-postgresql ( -- )
-    ! resource-path <postgresql-db> [
+    "localhost" "postgres" "" "factor-test" <postgresql-db> [
-        ! test-tuples
+        test-tuples
-    ! ] with-db ;
+    ] with-db ;
 
 person "PERSON"
 {
-    { "the-id" "ROWID" INTEGER +native-id+ }
+    { "the-id" "ID" SERIAL +native-id+ }
     { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
     { "the-number" "AGE" INTEGER { +default+ 0 } }
     { "real" "REAL" DOUBLE { +default+ 0.3 } }
@@ -51,18 +53,18 @@ person "PERSON"
 
 "billy" 10 3.14 <person> the-person set
 
-test-sqlite
+! test-sqlite
-! test-postgres
+ test-postgresql
 
-person "PERSON"
+! person "PERSON"
-{
+! {
-    { "the-id" "ROWID" INTEGER +assigned-id+ }
+    ! { "the-id" "ID" INTEGER +assigned-id+ }
-    { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+    ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
-    { "the-number" "AGE" INTEGER { +default+ 0 } }
+    ! { "the-number" "AGE" INTEGER { +default+ 0 } }
-    { "real" "REAL" DOUBLE { +default+ 0.3 } }
+    ! { "real" "REAL" DOUBLE { +default+ 0.3 } }
-} define-persistent
+! } define-persistent
 
-1 "billy" 20 6.28 <assigned-person> the-person set
+! 1 "billy" 20 6.28 <assigned-person> the-person set
 
-test-sqlite
+! test-sqlite
-! test-postgres
+! test-postgresql

extra/db/tuples/tuples.factor

@@ -38,12 +38,28 @@ TUPLE: no-slot-named ;
     [ db-table dupd ] swap
     [ <prepared-statement> ] 3compose cache nip ; inline
 
-HOOK: create-sql db ( columns table -- sql )
+HOOK: create-sql db ( columns table -- seq )
-HOOK: drop-sql db ( table -- sql )
+HOOK: drop-sql db ( columns table -- seq )
-HOOK: insert-sql* db ( columns table -- sql )
+
-HOOK: update-sql* db ( columns table -- sql )
+HOOK: insert-sql* db ( columns table -- slot-names sql )
-HOOK: delete-sql* db ( columns table -- sql )
+HOOK: update-sql* db ( columns table -- slot-names sql )
-HOOK: select-sql* db ( columns table -- sql )
+HOOK: delete-sql* db ( columns table -- slot-names sql )
+HOOK: select-sql db ( tuple -- statement )
+
+HOOK: row-column-typed db ( result-set n type -- sql )
+HOOK: sql-type>factor-type db ( obj type -- obj )
+HOOK: tuple>params db ( columns tuple -- obj )
+
+
+HOOK: make-slot-names* db ( quot -- seq )
+HOOK: column-slot-name% db ( spec -- )
+HOOK: column-bind-name% db ( spec -- )
+
+: make-slots-names ( quot -- seq str )
+    [ make-column-names ] "" make ; inline
+: slot-name% ( seq -- ) first % ;
+: column-name% ( seq -- ) second % ;
+: column-type% ( seq -- ) third % ;
 
 : insert-sql ( columns class -- statement )
     db get db-insert-statements [ insert-sql* ] cache-statement ;
@@ -54,30 +70,29 @@ HOOK: select-sql* db ( columns table -- sql )
 : delete-sql ( columns class -- statement )
     db get db-delete-statements [ delete-sql* ] cache-statement ;
 
-: select-sql ( columns class -- statement )
-    db get db-select-statements [ select-sql* ] cache-statement ;
-
-HOOK: tuple>params db ( columns tuple -- obj )
 
 : tuple-statement ( columns tuple quot -- statement )
     >r [ tuple>params ] 2keep class r> call
     2dup . .
     [ bind-statement ] keep ;
 
-: do-tuple-statement ( tuple columns-quot statement-quot -- )
+: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
     >r [ class db-columns ] swap compose keep
-    r> tuple-statement execute-statement ;
+    r> tuple-statement ;
+
+: do-tuple-statement ( tuple columns-quot statement-quot -- )
+    make-tuple-statement execute-statement ;
 
 : create-table ( class -- )
     dup db-columns swap db-table create-sql sql-command ;
     
 : drop-table ( class -- )
-    db-table drop-sql sql-command ;
+    dup db-columns swap db-table drop-sql sql-command ;
 
 : insert-tuple ( tuple -- )
     [
-        [ maybe-remove-id ] [ insert-sql ] do-tuple-statement
+        [ maybe-remove-id ] [ insert-sql ]
-        last-id
+        make-tuple-statement insert-statement
     ] keep set-primary-key ;
 
 : update-tuple ( tuple -- )
@@ -86,8 +101,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
 : delete-tuple ( tuple -- )
     [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
 
-! : select-tuple ( tuple -- )
+: select-tuple ( tuple -- )
-  !  [ select-sql ] bind-tuple do-query ;
+    [ select-sql ] keep do-query ;
 
 : persist ( tuple -- )
     dup primary-key [ update-tuple ] [ insert-tuple ] if ;

extra/db/types/types.factor

@@ -11,6 +11,12 @@ SYMBOL: +assigned-id+
 : primary-key? ( spec -- ? )
     [ { +native-id+ +assigned-id+ } member? ] contains? ;
 
+: contains-id? ( columns id -- ? )
+    swap [ member? ] with contains? ;
+    
+: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
+: native-id? ( columns -- ? ) +native-id+ contains-id? ;
+
 ! Same concept, SQLite has autoincrement, PostgreSQL has serial
 SYMBOL: +autoincrement+
 SYMBOL: +serial+
@@ -22,6 +28,7 @@ SYMBOL: +not-null+
 
 SYMBOL: +has-many+
 
+SYMBOL: SERIAL
 SYMBOL: INTEGER
 SYMBOL: DOUBLE
 SYMBOL: BOOLEAN

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/help/handbook/handbook.factor

@@ -1,8 +1,8 @@
-USING: help help.markup help.syntax help.topics
+USING: help help.markup help.syntax help.definitions help.topics
-namespaces words sequences classes assocs vocabs kernel
+namespaces words sequences classes assocs vocabs kernel arrays
-arrays prettyprint.backend kernel.private io tools.browser
+prettyprint.backend kernel.private io generic math system
-generic math tools.profiler system ui strings sbufs vectors
+strings sbufs vectors byte-arrays bit-arrays float-arrays
-byte-arrays bit-arrays float-arrays quotations help.lint ;
+quotations ;
 IN: help.handbook
 
 ARTICLE: "conventions" "Conventions"
@@ -161,15 +161,20 @@ ARTICLE: "io" "Input and output"
 { $subsection "io.timeouts" } ;
 
 ARTICLE: "tools" "Developer tools"
-{ $subsection "tools.annotations" }
+"Exploratory tools:"
-{ $subsection "tools.crossref" }
 { $subsection "editor" }
+{ $subsection "tools.crossref" }
 { $subsection "inspector" }
+"Debugging tools:"
+{ $subsection "tools.annotations" }
+{ $subsection "tools.test" }
 { $subsection "meta-interpreter" }
+"Performance tools:"
 { $subsection "tools.memory" }
 { $subsection "profiling" }
-{ $subsection "tools.test" }
 { $subsection "timing" }
+{ $subsection "tools.disassembler" }
+"Deployment tools:"
 { $subsection "tools.deploy" } ;
 
 ARTICLE: "article-index" "Article index"
@@ -201,7 +206,6 @@ ARTICLE: "handbook" "Factor documentation"
 { $subsection "cookbook" }
 { $subsection "first-program" }
 { $subsection "vocab-index" }
-{ $subsection "changes" }
 { $heading "Language reference" }
 { $subsection "conventions" }
 { $subsection "syntax" }
@@ -231,137 +235,6 @@ ARTICLE: "handbook" "Factor documentation"
 { $subsection "type-index" }
 { $subsection "class-index" } ;
 
-
-USING: io.files io.sockets float-arrays inference ;
-
-ARTICLE: "changes" "Changes in the latest release"
-{ $heading "Factor 0.91" }
-{ $subheading "Performance" }
-{ $list
-    { "Continuations are now supported by the static stack effect system. This means that the " { $link infer } " word and the optimizing compiler now both support code which uses continuations." }
-    { "Many words which previously ran in the interpreter, such as error handling and I/O, are now compiled to optimized machine code." }
-    { "A non-optimizing, just-in-time compiler replaces the interpreter with no loss in functionality or introspective ability." }
-    { "The non-optimizing compiler compiles quotations the first time they are called, generating a series of stack pushes and subroutine calls. It offers a 33%-50% performance increase over the interpreter." }
-    { "The optimizing compiler now performs some more representation inference. Alien pointers are unboxed where possible. This improves performance of the " { $vocab-link "ogg.player" } " Ogg Theora video player." }
-    { "The queue of sleeping tasks is now a sorted priority queue. This reduces overhead for workloads involving large numbers of sleeping threads (Doug Coleman)" }
-    { "Improved hash code algorithm for sequences" }
-    { "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
-    { "New " { $link big-random } " word for generating large random numbers quickly" }
-    { "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." }
-    { "Calls to " { $link member? } " with a literal sequence are now open-coded. If there are four or fewer elements, a series of conditionals are generated; if there are more than four elements, there is a hash dispatch followed by conditionals in each branch." }
-}
-{ $subheading "IO" }
-{ $list
-    { "More robust Windows CE native I/O" }
-    { "New " { $link os-envs } " word to get the current set of environment variables" }
-    { "Redesigned " { $vocab-link "io.launcher" } " supports passing environment variables to the child process" }
-    { { $link <process-stream> } " implemented on Windows (Doug Coleman)" }
-    { "Updated " { $vocab-link "io.mmap" } " for new module system, now supports Windows CE (Doug Coleman)" }
-    { { $vocab-link "io.sniffer" } " - packet sniffer library (Doug Coleman, Elie Chaftari)" }
-    { { $vocab-link "io.server" } " - improved logging support, logs to a file by default" }
-    { { $vocab-link "io.files" } " - several new file system manipulation words added" }
-    { { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" }
-    { { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $snippet "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
-}
-{ $subheading "Tools" }
-{ $list
-    { "Graphical deploy tool added - see " { $link "ui.tools.deploy" } }
-    { "The deploy tool now supports Windows" }
-    { { $vocab-link "network-clipboard" } " - clipboard synchronization with a simple TCP/IP protocol" }
-}
-{ $subheading "UI" }
-{ $list
-    { { $vocab-link "cairo" } " - updated for new module system, new features (Sampo Vuori)" }
-    { { $vocab-link "springies" } " - physics simulation UI demo (Eduardo Cavazos)" }
-    { { $vocab-link "ui.gadgets.buttons" } " - added check box and radio button gadgets" }
-    { "Double- and triple-click-drag now supported in the editor gadget to select words or lines at a time" }
-    { "Windows can be closed on request now using " { $link close-window } }
-    { "New icons (Elie Chaftari)" }
-}
-{ $subheading "Libraries" }
-{ $list
-    { "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } }
-    { "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." }
-    { "The optimizing compiler no longer depends on the number tower and it is possible to bootstrap a minimal image by just passing " { $snippet "-include=compiler" } " to stage 2 bootstrap." }
-    { { $vocab-link "benchmark.knucleotide" } " - new benchmark (Eric Mertens)" }
-    { { $vocab-link "channels" } " - concurrent message passing over message channels" }
-    { { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" }
-    { { $vocab-link "dlists" } " - various updates (Doug Coleman)" }
-    { { $vocab-link "editors.emeditor" } " - EmEditor integration (Doug Coleman)" }
-    { { $vocab-link "editors.editplus" } " - EditPlus integration (Aaron Schaefer)" }
-    { { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" }
-    { { $vocab-link "editors.ted-notepad" } " - TED Notepad integration (Doug Coleman)" }
-    { { $vocab-link "editors.ultraedit" } " - UltraEdit integration (Doug Coleman)" }
-    { { $vocab-link "globs" } " - simple Unix shell-style glob patterns" }
-    { { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" }
-    { { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" }
-    { { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" }
-    { { $vocab-link "rss" } " - add Atom feed generation (Daniel Ehrenberg)" }
-    { { $vocab-link "tuples.lib" } " - some utility words for working with tuples (Doug Coleman)" }
-    { { $vocab-link "webapps.pastebin" } " - improved appearance, add Atom feed generation, add syntax highlighting using " { $vocab-link "xmode" } }
-    { { $vocab-link "webapps.planet" } " - add Atom feed generation" }
-}
-{ $heading "Factor 0.90" }
-{ $subheading "Core" }
-{ $list
-    { "New module system; see " { $link "vocabs.loader" } ". (Eduardo Cavazos)" }
-    { "Tuple constructors are defined differently now; see " { $link "tuple-constructors" } "." }
-    { "Mixin classes implemented; these are essentially extensible unions. See " { $link "mixins" } "."  }
-    { "New " { $link float-array } " data type implements a space-efficient sequence of floats." }
-    { "Moved " { $link <file-appender> } ", " { $link delete-file } ", " { $link make-directory } ", " { $link delete-directory } " words from " { $snippet "libs/io" } " into the core, and fixed them to work on more platforms." }
-    { "New " { $link host-name } " word." }
-    { "The " { $link directory } " word now outputs an array of pairs, with the second element of each pair indicating if that entry is a subdirectory. This saves an unnecessary " { $link stat } " call when traversing directory hierarchies, which speeds things up." }
-    { "IPv6 is now supported, along with Unix domain sockets (the latter on Unix systems only). The stack effects of " { $link <client> } " and " { $link <server> } " have changed, since they now take generic address specifiers; see " { $link "network-streams" } "." }
-    { "The stage 2 bootstrap process is more flexible, and various subsystems such as help, tools and the UI can be omitted by supplying command line switches; see " { $link "bootstrap-cli-args" } "." }
-    { "The " { $snippet "-shell" } " command line switch has been replaced by a " { $snippet "-run" } " command line switch; see " { $link "standard-cli-args" } "." }
-    { "Variable usage inference has been removed; the " { $link infer } " word no longer reports this information." }
-
-}
-{ $subheading "Tools" }
-{ $list
-    { "Stand-alone image deployment; see " { $link "tools.deploy" } "." }
-    { "Stand-alone application bundle deployment on Mac OS X; see " { $vocab-link "tools.deploy.app" } "." }
-    { "New vocabulary browser tool in the UI." }
-    { "New profiler tool in the UI." }
-}
-{ $subheading "Extras" }
-"Most existing libraries were improved when ported to the new module system; the most notable changes include:"
-{ $list
-    { { $vocab-link "asn1" } ": ASN1 parser and writer. (Elie Chaftari)" }
-    { { $vocab-link "benchmark" } ": new set of benchmarks." }
-    { { $vocab-link "cfdg" } ": Context-free design grammar implementation; see " { $url "http://www.chriscoyne.com/cfdg/" } ". (Eduardo Cavazos)" }
-    { { $vocab-link "cryptlib" } ": Cryptlib library binding. (Elie Chaftari)" }
-    { { $vocab-link "cryptlib.streams" } ": Streams which perform SSL encryption and decryption. (Matthew Willis)" }
-    { { $vocab-link "hints" } ": Give type specialization hints to the compiler." }
-    { { $vocab-link "inverse" } ": Invertible computation and concatenative pattern matching. (Daniel Ehrenberg)" }
-    { { $vocab-link "ldap" } ": OpenLDAP library binding. (Elie Chaftari)" }
-    { { $vocab-link "locals" } ": Efficient lexically scoped locals, closures, and local words." }
-    { { $vocab-link "mortar" } ": Experimental message-passing object system. (Eduardo Cavazos)" }
-    { { $vocab-link "openssl" } ": OpenSSL library binding. (Elie Chaftari)" }
-    { { $vocab-link "pack" } ": Utility for reading and writing binary data. (Doug Coleman)" }
-    { { $vocab-link "pdf" } ": Haru PDF library binding. (Elie Chaftari)" }
-    { { $vocab-link "qualified" } ": Refer to words from another vocabulary without adding the entire vocabulary to the search path. (Daniel Ehrenberg)" }
-    { { $vocab-link "roman" } ": Reading and writing Roman numerals. (Doug Coleman)" }
-    { { $vocab-link "scite" } ": SciTE editor integration. (Clemens Hofreither)" }
-    { { $vocab-link "smtp" } ": SMTP client with support for CRAM-MD5 authentication. (Elie Chaftari, Dirk Vleugels)" }
-    { { $vocab-link "tuple-arrays" } ": Space-efficient packed tuple arrays. (Daniel Ehrenberg)" }
-    { { $vocab-link "unicode" } ": major new functionality added. (Daniel Ehrenberg)" }
-}
-{ $subheading "Performance" }
-{ $list
-    { "The " { $link curry } " word now runs in constant time, and curried quotations can be called from compiled code; this allows for abstractions and idioms which were previously impractical due to performance issues. In particular, words such as " { $snippet "each-with" } " and " { $snippet "map-with" } " are gone; " { $snippet "each-with" } " can now be written as " { $snippet "with each" } ", and similarly for other " { $snippet "-with" } " combinators." }
-    "Improved generational promotion strategy in garbage collector reduces the amount of junk which makes its way into tenured space, which in turn reduces the frequency of full garbage collections."
-    "Faster generic word dispatch and union membership testing."
-    { "Alien memory accessors (" { $link "reading-writing-memory" } ") are compiled as intrinsics where possible, which improves performance in code which iteroperates with C libraries." }
-}
-{ $subheading "Platforms" }
-{ $list
-    "Networking support added for Windows CE. (Doug Coleman)"
-    "UDP/IP networking support added for all Windows platforms. (Doug Coleman)"
-    "Solaris/x86 fixes. (Samuel Tardieu)"
-    "Linux/AMD64 port works again."
-} ;
-
 { <array> <string> <sbuf> <vector> <byte-array> <bit-array> <float-array> }
 related-words
 

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-docs.factor

@@ -90,6 +90,10 @@ HELP: get-environment
 { $values { "env" "an association" } }
 { $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
 
+HELP: current-process-handle
+{ $values { "handle" "a process handle" } }
+{ $description "Returns the handle of the current process." } ;
+
 HELP: run-process*
 { $values { "desc" "a launch descriptor" } { "handle" "a process handle" } }
 { $contract "Launches a process using the launch descriptor." }
@@ -186,6 +190,8 @@ ARTICLE: "io.launcher" "Launching OS processes"
 { $subsection try-process }
 "Stopping processes:"
 { $subsection kill-process }
+"Finding the current process handle:"
+{ $subsection current-process-handle }
 "Redirecting standard input and output to a pipe:"
 { $subsection <process-stream> }
 { $subsection with-process-stream }

extra/io/launcher/launcher.factor

@@ -76,6 +76,8 @@ SYMBOL: +append-environment+
         { [ dup assoc? ] [ >hashtable ] }
     } cond ;
 
+HOOK: current-process-handle io-backend ( -- handle )
+
 HOOK: run-process* io-backend ( desc -- handle )
 
 : wait-for-process ( process -- status )
@@ -119,7 +121,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

@@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.unix.backend io.unix.files
 io.nonblocking sequences kernel namespaces math system
  alien.c-types debugger continuations arrays assocs 
 combinators unix.process parser-combinators memoize 
-promises strings threads ;
+promises strings threads unix ;
 IN: io.unix.launcher
 
 ! Search unix first
@@ -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 ( -- )
     [
@@ -70,6 +71,8 @@ MEMO: 'arguments' ( -- parser )
         io-error
     ] [ error. :c flush ] recover 1 exit ;
 
+M: unix-io current-process-handle ( -- handle ) getpid ;
+
 M: unix-io run-process* ( desc -- pid )
     [
         [ spawn-process ] [ ] with-fork <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,29 @@ 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 current-process-handle ( -- handle )
+    GetCurrentProcessId ;
 
 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/files/files.factor

@@ -2,7 +2,7 @@ USING: continuations destructors io.buffers io.files io.backend
 io.timeouts io.nonblocking io.windows io.windows.nt.backend
 kernel libc math threads windows windows.kernel32 alien.c-types
 alien.arrays sequences combinators combinators.lib sequences.lib
-ascii splitting alien strings ;
+ascii splitting alien strings assocs ;
 IN: io.windows.nt.files
 
 M: windows-nt-io cwd
@@ -60,7 +60,7 @@ M: windows-nt-io root-directory? ( path -- ? )
 
 M: windows-nt-io normalize-pathname ( string -- string )
     dup string? [ "pathname must be a string" throw ] unless
-    "/" split "\\" join
+    { { CHAR: / CHAR: \\ } } substitute
     cwd swap windows-path+
     [ "/\\." member? ] right-trim
     dup peek CHAR: : = [ "\\" append ] when ;

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