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

core/classes/algebra/algebra-tests.factor

@@ -13,8 +13,6 @@ IN: classes.algebra.tests
 \ flatten-class must-infer
 \ flatten-builtin-class must-infer
 
-: class= ( cls1 cls2 -- ? ) [ class<= ] [ swap class<= ] 2bi and ;
-
 : class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;
 
 : class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;

core/classes/algebra/algebra.factor

@@ -186,6 +186,9 @@ M: anonymous-complement (classes-intersect?)
         [ [ rank-class ] bi@ < ]
     } cond ;
 
+: class= ( first second -- ? )
+    [ class<= ] [ swap class<= ] 2bi and ;
+
 : largest-class ( seq -- n elt )
     dup [ [ class< ] with contains? not ] curry find-last
     [ "Topological sort failed" throw ] unless* ;

core/combinators/combinators-docs.factor

@@ -25,8 +25,6 @@ $nl
 $nl
 "A combinator which can help with implementing methods on " { $link hashcode* } ":"
 { $subsection recursive-hashcode }
-"An oddball combinator:"
-{ $subsection with-datastack }
 { $subsection "combinators-quot" }
 { $see-also "quotations" "dataflow" } ;
 
@@ -116,13 +114,6 @@ HELP: no-case
 { $description "Throws a " { $link no-case } " error." }
 { $error-description "Thrown by " { $link case } " if the object at the top of the stack does not match any case, and no default case is given." } ;
 
-HELP: with-datastack
-{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
-{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
-{ $examples
-    { $example "USING: combinators math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
-} ;
-
 HELP: recursive-hashcode
 { $values { "n" integer } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( n obj -- code )" } } { "code" integer } }
 { $description "A combinator used to implement methods for the " { $link hashcode* } " generic word. If " { $snippet "n" } " is less than or equal to zero, outputs 0, otherwise calls the quotation." } ;

core/combinators/combinators.factor

@@ -138,12 +138,6 @@ ERROR: no-case ;
         [ drop linear-case-quot ]
     } cond ;
 
-! with-datastack
-: with-datastack ( stack quot -- newstack )
-    datastack >r
-    >r >array set-datastack r> call
-    datastack r> swap suffix set-datastack 2nip ; inline
-
 ! recursive-hashcode
 : recursive-hashcode ( n obj quot -- code )
     pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline

core/continuations/continuations-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax kernel kernel.private
 continuations.private vectors arrays namespaces
-assocs words quotations lexer ;
+assocs words quotations lexer sequences ;
 IN: continuations
 
 ARTICLE: "errors-restartable" "Restartable errors"
@@ -77,6 +77,8 @@ $nl
 "Another two words resume continuations:"
 { $subsection continue }
 { $subsection continue-with }
+"Reflecting the datastack:"
+{ $subsection with-datastack }
 "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
 { $subsection "continuations.private" } ;
 
@@ -202,3 +204,10 @@ HELP: save-error
 { $values { "error" "an error" } }
 { $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
 $low-level-note ;
+
+HELP: with-datastack
+{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
+{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
+{ $examples
+    { $example "USING: combinators math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
+} ;

core/continuations/continuations-tests.factor

@@ -104,3 +104,7 @@ SYMBOL: error-counter
 [ ] [ [ return ] with-return ] unit-test
 
 [ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with
+
+[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
+
+\ with-datastack must-infer

core/continuations/continuations.factor

@@ -109,6 +109,14 @@ SYMBOL: return-continuation
 : return ( -- )
     return-continuation get continue ;
 
+: with-datastack ( stack quot -- newstack )
+    [
+        [
+            [ [ { } like set-datastack ] dip call datastack ] dip
+            continue-with
+        ] 3 (throw)
+    ] callcc1 2nip ;
+
 GENERIC: compute-restarts ( error -- seq )
 
 <PRIVATE

core/generic/math/math.factor

@@ -22,8 +22,14 @@ PREDICATE: math-class < class
         [ drop { 100 100 } ]
     } cond ;
     
-: math-class-max ( class class -- class )
+: math-class<=> ( class1 class2 -- class )
-    [ [ math-precedence ] compare +gt+ eq? ] most ;
+    [ math-precedence ] compare +gt+ eq? ;
+
+: math-class-max ( class1 class2 -- class )
+    [ math-class<=> ] most ;
+
+: math-class-min ( class1 class2 -- class )
+    [ swap math-class<=> ] most ;
 
 : (math-upgrade) ( max class -- quot )
     dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;

core/inference/transforms/transforms-tests.factor

@@ -10,16 +10,6 @@ classes classes.tuple ;
 
 [ 6 ] [ 1 2 3 compose-n-test ] unit-test
 
-[ 0 ] [ { } bitfield-quot call ] unit-test
-
-[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
-
-[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
-
-[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
-
-[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
-
 TUPLE: color r g b ;
 
 C: <color> color

core/kernel/kernel.factor

@@ -165,12 +165,16 @@ GENERIC: boa ( ... class -- tuple )
     compose compose ; inline
 
 ! Booleans
-: not ( obj -- ? ) f eq? ; inline
+: not ( obj -- ? )
+    #! Not inline because its special-cased by compiler.
+    f eq? ;
+
+: and ( obj1 obj2 -- ? )
+    #! Not inline because its special-cased by compiler.
+    over ? ;
 
 : >boolean ( obj -- ? ) t f ? ; inline
 
-: and ( obj1 obj2 -- ? ) over ? ; inline
-
 : or ( obj1 obj2 -- ? ) dupd ? ; inline
 
 : xor ( obj1 obj2 -- ? ) dup not swap ? ; inline

core/math/intervals/intervals-docs.factor

@@ -14,6 +14,10 @@ ARTICLE: "math-intervals-new" "Creating intervals"
 { $subsection [-inf,a) }
 { $subsection [a,inf] }
 { $subsection (a,inf] }
+"The set of all real numbers with infinities:"
+{ $subsection [-inf,inf] }
+"The empty set:"
+{ $subsection empty-interval }
 "Another constructor:"
 { $subsection points>interval } ;
 
@@ -24,16 +28,23 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic"
 { $subsection interval* }
 { $subsection interval/ }
 { $subsection interval/i }
-{ $subsection interval-shift }
+{ $subsection interval-mod }
+{ $subsection interval-rem }
 { $subsection interval-min }
 { $subsection interval-max }
+"Bitwise operations on intervals:"
+{ $subsection interval-shift }
+{ $subsection interval-bitand }
+{ $subsection interval-bitor }
+{ $subsection interval-bitxor }
 "Unary operations on intervals:"
 { $subsection interval-1+ }
 { $subsection interval-1- }
 { $subsection interval-neg }
 { $subsection interval-bitnot }
 { $subsection interval-recip }
-{ $subsection interval-2/ } ;
+{ $subsection interval-2/ }
+{ $subsection interval-abs } ;
 
 ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
 { $subsection interval-contains? }
@@ -53,12 +64,20 @@ ARTICLE: "math-intervals-compare" "Comparing intervals"
 { $subsection assume> }
 { $subsection assume>= } ;
 
+ARTICLE: "math-interval-properties" "Properties of interval arithmetic"
+"For some operations, interval arithmetic yields inaccurate results, either because the result of lifting some operations to intervals does not result in intervals (bitwise operations, for example) or for the sake of simplicity of implementation."
+$nl
+"However, one important property holds for all operations. Suppose " { $emphasis "I, J" } " are intervals and " { $emphasis "op" } " is an operation. If " { $emphasis "x" } " is an element of " { $emphasis "I" } " and " { $emphasis "y" } " is an element of " { $emphasis "J" } ", then " { $emphasis "x op y" } " is an element of " { $emphasis "I op J" } "."
+$nl
+"In other words, the resulting interval might be an overestimate, but it is never an underestimate." ;
+
 ARTICLE: "math-intervals" "Intervals"
 "Interval arithmetic is performed on ranges of real numbers, rather than exact values. It is used by the Factor compiler to convert arbitrary-precision arithmetic to machine arithmetic, by inferring bounds for integer calculations."
-$nl
+{ $subsection "math-interval-properties" }
 "The class of intervals:"
 { $subsection interval }
 { $subsection interval? }
+"Interval operations:"
 { $subsection "math-intervals-new" }
 { $subsection "math-intervals-arithmetic" }
 { $subsection "math-intervals-sets" }
@@ -144,6 +163,26 @@ HELP: interval-max
 { $values { "i1" interval } { "i2" interval } { "i3" interval } }
 { $description "Outputs the interval values obtained by lifting the " { $link max } " word to " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
 
+HELP: interval-mod
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Outputs an interval containing all possible values obtained by aplying " { $link mod } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
+
+HELP: interval-rem
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Outputs an interval containing all possible values obtained by aplying " { $link rem } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
+
+HELP: interval-bitand
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Outputs an interval containing all possible values obtained by aplying " { $link bitand } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
+
+HELP: interval-bitor
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Outputs an interval containing all possible values obtained by aplying " { $link bitor } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
+
+HELP: interval-bitxor
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Outputs an interval containing all possible values obtained by aplying " { $link bitxor } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
+
 HELP: interval-min
 { $values { "i1" interval } { "i2" interval } { "i3" interval } }
 { $description "Outputs the interval values obtained by lifting the " { $link min } " word to " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
@@ -160,6 +199,10 @@ HELP: interval-neg
 { $values { "i1" interval } { "i2" interval } }
 { $description "Negates an interval." } ;
 
+HELP: interval-abs
+{ $values { "i1" interval } { "i2" interval } }
+{ $description "Absolute value of an interval." } ;
+
 HELP: interval-intersect
 { $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval  } " or " { $link f } } }
 { $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ;
@@ -181,12 +224,16 @@ HELP: interval-closure
 { $description "Outputs the smallest closed interval containing the endpoints of " { $snippet "i1" } "." } ;
 
 HELP: interval/
-{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
-{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link / } " to perform the division. Outputs " { $link f } " if " { $snippet "i2" } " contains points arbitrarily close to zero." } ;
+{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link / } " to perform the division." } ;
 
 HELP: interval/i
-{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
-{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link /i } " to perform the division. Outputs " { $link f } " if " { $snippet "i2" } " contains points arbitrarily close to zero." } ;
+{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link /i } " to perform the division." } ;
+
+HELP: interval/f
+{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
+{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link /f } " to perform the division." } ;
 
 HELP: interval-recip
 { $values { "i1" interval } { "i2" interval } }

core/math/intervals/intervals-tests.factor

@@ -1,7 +1,16 @@
 USING: math.intervals kernel sequences words math math.order
-arrays prettyprint tools.test random vocabs combinators ;
+arrays prettyprint tools.test random vocabs combinators
+accessors ;
 IN: math.intervals.tests
 
+[ empty-interval ] [ 2 2 (a,b) ] unit-test
+
+[ empty-interval ] [ 2 2 [a,b) ] unit-test
+
+[ empty-interval ] [ 2 2 (a,b] ] unit-test
+
+[ empty-interval ] [ 3 2 [a,b] ] unit-test
+
 [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test
 
 [ T{ interval f { 1 t } { 2 f } } ] [ 1 2 [a,b) ] unit-test
@@ -18,6 +27,10 @@ IN: math.intervals.tests
 [ t ] [ { 4 f } { 3 t } endpoint> ] unit-test
 [ f ] [ { 3 f } { 3 t } endpoint> ] unit-test
 
+[ empty-interval ] [ 1 2 [a,b] empty-interval interval+ ] unit-test
+
+[ empty-interval ] [ empty-interval 1 2 [a,b] interval+ ] unit-test
+
 [ t ] [
     1 2 [a,b] -3 3 [a,b] interval+ -2 5 [a,b] =
 ] unit-test
@@ -26,10 +39,18 @@ IN: math.intervals.tests
     1 2 [a,b] -3 3 (a,b) interval+ -2 5 (a,b) =
 ] unit-test
 
+[ empty-interval ] [ 1 2 [a,b] empty-interval interval- ] unit-test
+
+[ empty-interval ] [ empty-interval 1 2 [a,b] interval- ] unit-test
+
 [ t ] [
     1 2 [a,b] 0 1 [a,b] interval- 0 2 [a,b] =
 ] unit-test
 
+[ empty-interval ] [ 1 2 [a,b] empty-interval interval* ] unit-test
+
+[ empty-interval ] [ empty-interval 1 2 [a,b] interval* ] unit-test
+
 [ t ] [
     1 2 [a,b] 0 4 [a,b] interval* 0 8 [a,b] =
 ] unit-test
@@ -50,6 +71,10 @@ IN: math.intervals.tests
     -1 1 [a,b] -1 1 (a,b] interval* -1 1 [a,b] =
 ] unit-test
 
+[ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test
+
+[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test
+
 [ t ] [
     0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] =
 ] unit-test
@@ -64,9 +89,21 @@ IN: math.intervals.tests
     0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
 ] unit-test
 
-[ f ] [ 0 5 [a,b] -1 [a,a] interval-intersect ] unit-test
+[ empty-interval ] [ 0 5 [a,b] -1 [a,a] interval-intersect ] unit-test
 
-[ f ] [ 0 5 (a,b] 0 [a,a] interval-intersect ] unit-test
+[ empty-interval ] [ 0 5 (a,b] 0 [a,a] interval-intersect ] unit-test
+
+[ empty-interval ] [ empty-interval -1 [a,a] interval-intersect ] unit-test
+
+[ empty-interval ] [ 0 5 (a,b] empty-interval interval-intersect ] unit-test
+
+[ t ] [
+    empty-interval empty-interval interval-subset?
+] unit-test
+
+[ t ] [
+    empty-interval 0 1 [a,b] interval-subset?
+] unit-test
 
 [ t ] [
     0 1 (a,b) 0 1 [a,b] interval-subset?
@@ -84,9 +121,11 @@ IN: math.intervals.tests
     1 0 1 (a,b) interval-contains?
 ] unit-test
 
-[ f ] [ -1 1 (a,b) -1 1 (a,b) interval/ ] unit-test
+[ empty-interval ] [ -1 1 (a,b) empty-interval interval/ ] unit-test
 
-[ f ] [ -1 1 (a,b) 0 1 (a,b) interval/ ] unit-test
+[ t ] [ -1 1 (a,b) -1 1 (a,b) interval/ [-inf,inf] = ] unit-test
+
+[ t ] [ -1 1 (a,b) 0 1 (a,b) interval/ [-inf,inf] = ] unit-test
 
 "math.ratios.private" vocab [
     [ t ] [
@@ -94,6 +133,8 @@ IN: math.intervals.tests
     ] unit-test
 ] when
 
+[ f ] [ empty-interval interval-singleton? ] unit-test
+
 [ t ] [ 1 [a,a] interval-singleton? ] unit-test
 
 [ f ] [ 1 1 [a,b) interval-singleton? ] unit-test
@@ -104,10 +145,14 @@ IN: math.intervals.tests
 
 [ 2 ] [ 1 3 [a,b) interval-length ] unit-test
 
-[ 0 ] [ f interval-length ] unit-test
+[ 0 ] [ empty-interval interval-length ] unit-test
 
 [ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test
 
+[ incomparable ] [ empty-interval 5 [a,a] interval< ] unit-test
+
+[ incomparable ] [ 5 [a,a] empty-interval interval< ] unit-test
+
 [ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test
 
 [ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test
@@ -128,6 +173,10 @@ IN: math.intervals.tests
 
 [ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test
 
+[ incomparable ] [ -1 1 (a,b] empty-interval interval>= ] unit-test
+
+[ incomparable ] [ empty-interval -1 1 (a,b] interval>= ] unit-test
+
 [ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test
 
 [ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test
@@ -156,11 +205,11 @@ IN: math.intervals.tests
     interval-contains?
 ] unit-test
 
-[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test
+[ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
 
 ! Interval random tester
 : random-element ( interval -- n )
-    dup interval-to first over interval-from first tuck - random +
+    dup to>> first over from>> first tuck - random +
     2dup swap interval-contains? [
         nip
     ] [
@@ -168,7 +217,7 @@ IN: math.intervals.tests
     ] if ;
 
 : random-interval ( -- interval )
-    1000 random dup 2 1000 random + +
+    2000 random 1000 - dup 2 1000 random + +
     1 random zero? [ [ neg ] bi@ swap ] when
     4 random {
         { 0 [ [a,b] ] }
@@ -177,12 +226,43 @@ IN: math.intervals.tests
         { 3 [ (a,b] ] }
     } case ;
 
-: random-op ( -- pair )
+: random-unary-op ( -- pair )
+    {
+        { bitnot interval-bitnot }
+        { abs interval-abs }
+        { 2/ interval-2/ }
+        { 1+ interval-1+ }
+        { 1- interval-1- }
+        { neg interval-neg }
+    }
+    "math.ratios.private" vocab [
+        { recip interval-recip } suffix
+    ] when
+    random ;
+
+: unary-test ( -- ? )
+    random-interval random-unary-op ! 2dup . .
+    0 pick interval-contains? over first \ recip eq? and [
+        2drop t
+    ] [
+        [ >r random-element ! dup .
+        r> first execute ] 2keep
+        second execute interval-contains?
+    ] if ;
+
+[ t ] [ 80000 [ drop unary-test ] all? ] unit-test
+
+: random-binary-op ( -- pair )
     {
         { + interval+ }
         { - interval- }
         { * interval* }
         { /i interval/i }
+        { mod interval-mod }
+        { rem interval-rem }
+        { bitand interval-bitand }
+        { bitor interval-bitor }
+        { bitxor interval-bitxor }
         { shift interval-shift }
         { min interval-min }
         { max interval-max }
@@ -192,9 +272,9 @@ IN: math.intervals.tests
     ] when
     random ;
 
-: interval-test ( -- ? )
+: binary-test ( -- ? )
-    random-interval random-interval random-op ! 3dup . . .
+    random-interval random-interval random-binary-op ! 3dup . . .
-    0 pick interval-contains? over first { / /i } member? and [
+    0 pick interval-contains? over first { / /i mod rem } member? and [
         3drop t
     ] [
         [ >r [ random-element ] bi@ ! 2dup . .
@@ -202,7 +282,7 @@ IN: math.intervals.tests
         second execute interval-contains?
     ] if ;
 
-[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
+[ t ] [ 80000 [ drop binary-test ] all? ] unit-test
 
 : random-comparison ( -- pair )
     {
@@ -215,11 +295,7 @@ IN: math.intervals.tests
 : comparison-test ( -- ? )
     random-interval random-interval random-comparison
     [ >r [ random-element ] bi@ r> first execute ] 3keep
-    second execute dup incomparable eq? [
+    second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
-        2drop t
-    ] [
-        =
-    ] if ;
 
 [ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
 
@@ -234,3 +310,25 @@ IN: math.intervals.tests
 [ t ] [ -10 10 [a,b] -100 0 [a,b] assume<= -10 0 [a,b] = ] unit-test
 
 [ t ] [ -10 10 [a,b] 0 100 [a,b] assume<= -10 10 [a,b] = ] unit-test
+
+[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
+
+! Test that commutative interval ops really are
+: random-interval-or-empty ( -- )
+    10 random 0 = [ empty-interval ] [ random-interval ] if ;
+
+: random-commutative-op ( -- op )
+    {
+        interval+ interval*
+        interval-bitor interval-bitand interval-bitxor
+        interval-max interval-min
+    } random ;
+
+[ t ] [
+    80000 [
+        drop
+        random-interval-or-empty random-interval-or-empty
+        random-commutative-op
+        [ execute ] [ swapd execute ] 3bi =
+    ] all?
+] unit-test

core/math/intervals/intervals.factor

@@ -5,9 +5,19 @@ USING: accessors kernel sequences arrays math math.order
 combinators generic ;
 IN: math.intervals
 
+SYMBOL: empty-interval
+
 TUPLE: interval { from read-only } { to read-only } ;
 
-C: <interval> interval
+: <interval> ( from to -- int )
+    over first over first {
+        { [ 2dup > ] [ 2drop 2drop empty-interval ] }
+        { [ 2dup = ] [
+            2drop over second over second and
+            [ interval boa ] [ 2drop empty-interval ] if
+        ] }
+        [ 2drop interval boa ]
+    } cond ;
 
 : open-point ( n -- endpoint ) f 2array ;
 
@@ -36,6 +46,9 @@ C: <interval> interval
 
 : (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
 
+: [-inf,inf] ( -- interval )
+    T{ interval f { -1./0. t } { 1./0. t } } ; inline
+
 : compare-endpoints ( p1 p2 quot -- ? )
     >r over first over first r> call [
         2drop t
@@ -68,9 +81,9 @@ C: <interval> interval
     [ endpoint-max ] reduce <interval> ;
 
 : (interval-op) ( p1 p2 quot -- p3 )
-    2over >r >r
+    [ [ first ] [ first ] [ ] tri* call ]
-    >r [ first ] bi@ r> call
+    [ drop [ second ] both? ]
-    r> r> [ second ] both? 2array ; inline
+    3bi 2array ; inline
 
 : interval-op ( i1 i2 quot -- i3 )
     {
@@ -80,16 +93,21 @@ C: <interval> interval
         [ [ from>> ] [ to>>   ] [ ] tri* (interval-op) ]
     } 3cleave 4array points>interval ; inline
 
-: interval+ ( i1 i2 -- i3 ) [ + ] interval-op ;
+: do-empty-interval ( i1 i2 quot -- i3 )
+    {
+        { [ pick empty-interval eq? ] [ drop drop ] }
+        { [ over empty-interval eq? ] [ drop nip ] }
+        [ call ]
+    } cond ; inline
 
-: interval- ( i1 i2 -- i3 ) [ - ] interval-op ;
+: interval+ ( i1 i2 -- i3 )
+    [ [ + ] interval-op ] do-empty-interval ;
 
-: interval* ( i1 i2 -- i3 ) [ * ] interval-op ;
+: interval- ( i1 i2 -- i3 )
+    [ [ - ] interval-op ] do-empty-interval ;
 
-: interval-integer-op ( i1 i2 quot -- i3 )
+: interval* ( i1 i2 -- i3 )
-    >r 2dup
+    [ [ * ] interval-op ] do-empty-interval ;
-    [ interval>points [ first integer? ] both? ] both?
-    r> [ 2drop f ] if ; inline
 
 : interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
 
@@ -101,32 +119,34 @@ C: <interval> interval
 
 : interval-sq ( i1 -- i2 ) dup interval* ;
 
-: make-interval ( from to -- int )
-    over first over first {
-        { [ 2dup > ] [ 2drop 2drop f ] }
-        { [ 2dup = ] [
-            2drop over second over second and
-            [ <interval> ] [ 2drop f ] if
-        ] }
-        [ 2drop <interval> ]
-    } cond ;
-
 : interval-intersect ( i1 i2 -- i3 )
+    {
+        { [ dup empty-interval eq? ] [ nip ] }
+        { [ over empty-interval eq? ] [ drop ] }
+        [
             2dup and [
                 [ interval>points ] bi@ swapd
-        [ swap endpoint> ] most
+                [ [ swap endpoint< ] most ]
-        >r [ swap endpoint< ] most r>
+                [ [ swap endpoint> ] most ] 2bi*
-        make-interval
+                <interval>
             ] [
                 or
-    ] if ;
+            ] if
+        ]
+    } cond ;
 
 : interval-union ( i1 i2 -- i3 )
+    {
+        { [ dup empty-interval eq? ] [ drop ] }
+        { [ over empty-interval eq? ] [ nip ] }
+        [
             2dup and [
                 [ interval>points 2array ] bi@ append points>interval
             ] [
                 2drop f
-    ] if ;
+            ] if
+        ]
+    } cond ;
 
 : interval-subset? ( i1 i2 -- ? )
     dupd interval-intersect = ;
@@ -135,47 +155,67 @@ C: <interval> interval
     >r [a,a] r> interval-subset? ;
 
 : interval-singleton? ( int -- ? )
+    dup empty-interval eq? [
+        drop f
+    ] [
         interval>points
         2dup [ second ] bi@ and
         [ [ first ] bi@ = ]
-    [ 2drop f ] if ;
+        [ 2drop f ] if
+    ] if ;
 
 : interval-length ( int -- n )
-    dup
+    {
+        { [ dup empty-interval eq? ] [ drop 0 ] }
+        { [ dup not ] [ drop 0 ] }
         [ interval>points [ first ] bi@ swap - ]
-    [ drop 0 ] if ;
+    } cond ;
 
 : interval-closure ( i1 -- i2 )
     dup [ interval>points [ first ] bi@ [a,b] ] when ;
 
+: interval-integer-op ( i1 i2 quot -- i3 )
+    >r 2dup
+    [ interval>points [ first integer? ] both? ] both?
+    r> [ 2drop [-inf,inf] ] if ; inline
+
 : interval-shift ( i1 i2 -- i3 )
     #! Inaccurate; could be tighter
-    [ [ shift ] interval-op ] interval-integer-op interval-closure ;
+    [
+        [
+            [ interval-closure ] bi@
+            [ shift ] interval-op
+        ] interval-integer-op
+    ] do-empty-interval ;
 
 : interval-shift-safe ( i1 i2 -- i3 )
+    [
         dup to>> first 100 > [
-        2drop f
+            2drop [-inf,inf]
         ] [
             interval-shift
-    ] if ;
+        ] if
+    ] do-empty-interval ;
 
 : interval-max ( i1 i2 -- i3 )
     #! Inaccurate; could be tighter
-    [ max ] interval-op interval-closure ;
+    [ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ;
 
 : interval-min ( i1 i2 -- i3 )
     #! Inaccurate; could be tighter
-    [ min ] interval-op interval-closure ;
+    [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
 
 : interval-interior ( i1 -- i2 )
-    interval>points [ first ] bi@ (a,b) ;
+    dup empty-interval eq? [
+        interval>points [ first ] bi@ (a,b)
+    ] unless ;
 
 : interval-division-op ( i1 i2 quot -- i3 )
     >r 0 over interval-closure interval-contains?
-    [ 2drop f ] r> if ; inline
+    [ 2drop [-inf,inf] ] r> if ; inline
 
 : interval/ ( i1 i2 -- i3 )
-    [ [ / ] interval-op ] interval-division-op ;
+    [ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ;
 
 : interval/-safe ( i1 i2 -- i3 )
     #! Just a hack to make the compiler work if bootstrap.math
@@ -184,8 +224,42 @@ C: <interval> interval
 
 : interval/i ( i1 i2 -- i3 )
     [
-        [ [ /i ] interval-op ] interval-integer-op
+        [
-    ] interval-division-op interval-closure ;
+            [
+                [ interval-closure ] bi@
+                [ /i ] interval-op
+            ] interval-integer-op
+        ] interval-division-op
+    ] do-empty-interval ;
+
+: interval/f ( i1 i2 -- i3 )
+    [ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
+
+: (interval-abs) ( i1 -- i2 )
+    interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ;
+
+: interval-abs ( i1 -- i2 )
+    {
+        { [ dup empty-interval eq? ] [ ] }
+        { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
+        [ (interval-abs) points>interval ]
+    } cond ;
+
+: interval-mod ( i1 i2 -- i3 )
+    #! Inaccurate.
+    [
+        [
+            nip interval-abs to>> first [ neg ] keep (a,b)
+        ] interval-division-op
+    ] do-empty-interval ;
+
+: interval-rem ( i1 i2 -- i3 )
+    #! Inaccurate.
+    [
+        [
+            nip interval-abs to>> first 0 swap [a,b)
+        ] interval-division-op
+    ] do-empty-interval ;
 
 : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
 
@@ -194,23 +268,24 @@ C: <interval> interval
 SYMBOL: incomparable
 
 : left-endpoint-< ( i1 i2 -- ? )
-    [ swap interval-subset? ] 2keep
+    [ swap interval-subset? ]
-    [ nip interval-singleton? ] 2keep
+    [ nip interval-singleton? ]
-    [ from>> ] bi@ =
+    [ [ from>> ] bi@ = ]
-    and and ;
+    2tri and and ;
 
 : right-endpoint-< ( i1 i2 -- ? )
-    [ interval-subset? ] 2keep
+    [ interval-subset? ]
-    [ drop interval-singleton? ] 2keep
+    [ drop interval-singleton? ]
-    [ to>> ] bi@ =
+    [ [ to>> ] bi@ = ]
-    and and ;
+    2tri and and ;
 
 : (interval<) ( i1 i2 -- i1 i2 ? )
     over from>> over from>> endpoint< ;
 
 : interval< ( i1 i2 -- ? )
     {
-        { [ 2dup interval-intersect not ] [ (interval<) ] }
+        { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+        { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
         { [ 2dup left-endpoint-< ] [ f ] }
         { [ 2dup right-endpoint-< ] [ f ] }
         [ incomparable ]
@@ -224,7 +299,8 @@ SYMBOL: incomparable
 
 : interval<= ( i1 i2 -- ? )
     {
-        { [ 2dup interval-intersect not ] [ (interval<) ] }
+        { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+        { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
         { [ 2dup right-endpoint-<= ] [ t ] }
         [ incomparable ]
     } cond 2nip ;
@@ -235,19 +311,69 @@ SYMBOL: incomparable
 : interval>= ( i1 i2 -- ? )
     swap interval<= ;
 
+: interval-bitand-pos ( i1 i2 -- ? )
+    [ to>> first ] bi@ min 0 swap [a,b] ;
+
+: interval-bitand-neg ( i1 i2 -- ? )
+    dup from>> first 0 < [ drop ] [ nip ] if
+    0 swap to>> first [a,b] ;
+
+: interval-nonnegative? ( i -- ? )
+    from>> first 0 >= ;
+
+: interval-bitand ( i1 i2 -- i3 )
+    #! Inaccurate.
+    [
+        {
+            {
+                [ 2dup [ interval-nonnegative? ] both? ]
+                [ interval-bitand-pos ]
+            }
+            {
+                [ 2dup [ interval-nonnegative? ] either? ]
+                [ interval-bitand-neg ]
+            }
+            [ 2drop [-inf,inf] ]
+        } cond
+    ] do-empty-interval ;
+
+: interval-bitor ( i1 i2 -- i3 )
+    #! Inaccurate.
+    [
+        2dup [ interval-nonnegative? ] both?
+        [
+            [ interval>points [ first ] bi@ ] bi@
+            4array supremum 0 swap next-power-of-2 [a,b]
+        ] [ 2drop [-inf,inf] ] if
+    ] do-empty-interval ;
+
+: interval-bitxor ( i1 i2 -- i3 )
+    #! Inaccurate.
+    interval-bitor ;
+
 : assume< ( i1 i2 -- i3 )
-    to>> first [-inf,a) interval-intersect ;
+    dup empty-interval eq? [ drop ] [
+        to>> first [-inf,a) interval-intersect
+    ] if ;
 
 : assume<= ( i1 i2 -- i3 )
-    to>> first [-inf,a] interval-intersect ;
+    dup empty-interval eq? [ drop ] [
+        to>> first [-inf,a] interval-intersect
+    ] if ;
 
 : assume> ( i1 i2 -- i3 )
-    from>> first (a,inf] interval-intersect ;
+    dup empty-interval eq? [ drop ] [
+        from>> first (a,inf] interval-intersect
+    ] if ;
 
 : assume>= ( i1 i2 -- i3 )
-    from>> first [a,inf] interval-intersect ;
+    dup empty-interval eq? [ drop ] [
+        from>> first [a,inf] interval-intersect
+    ] if ;
 
 : integral-closure ( i1 -- i2 )
+    dup empty-interval eq? [
         [ from>> first2 [ 1+ ] unless ]
         [ to>> first2 [ 1- ] unless ]
-    bi [a,b] ;
+        bi [a,b]
+    ] unless ;

core/math/math-docs.factor

@@ -130,38 +130,27 @@ HELP: /
 { $see-also "division-by-zero" } ;
 
 HELP: /i
-{ $values { "x" real } { "y" real } { "z" real } }
+{ $values { "x" real } { "y" real } { "z" integer } }
 { $description
     "Divides " { $snippet "x" } " by " { $snippet "y" } ", truncating the result to an integer."
-    { $list
-        "Integer division of fixnums may overflow and yield a bignum."
-        "Integer division of bignums always yields a bignum."
-        "Integer division of floats always yields a float."
-        "Integer division of ratios and complex numbers proceeds using the relevant mathematical rules."
-    }
 }
 { $see-also "division-by-zero" } ;
 
 HELP: /f
-{ $values { "x" real } { "y" real } { "z" real } }
+{ $values { "x" real } { "y" real } { "z" float } }
 { $description
     "Divides " { $snippet "x" } " by " { $snippet "y" } ", representing the result as a floating point number."
-    { $list 
-        "Integer division of fixnums may overflow and yield a bignum."
-        "Integer division of bignums always yields a bignum."            
-        "Integer division of floats always yields a float."
-        "Integer division of ratios and complex numbers proceeds using the relevant mathematical rules."
-    }
 }
 { $see-also "division-by-zero" } ;
 
 HELP: mod
-{ $values { "x" integer } { "y" integer } { "z" integer } }
+{ $values { "x" rational } { "y" rational } { "z" rational } }
 { $description
     "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative."
     { $list 
         "Modulus of fixnums always yields a fixnum."
         "Modulus of bignums always yields a bignum."    
+        { "Modulus of rationals always yields a rational. In this case, the remainder is computed using the formula " { $snippet "x - (x mod y) * y" } "." }
     }
 }
 { $see-also "division-by-zero" rem } ;
@@ -254,12 +243,13 @@ HELP: recip
 { $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
 
 HELP: rem
-{ $values { "x" integer } { "y" integer } { "z" integer } }
+{ $values { "x" rational } { "y" rational } { "z" rational } }
 { $description
     "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive."
     { $list 
-        "Modulus of fixnums always yields a fixnum."
+        "Given fixnums, always yields a fixnum."
-        "Modulus of bignums always yields a bignum."            
+        "Given bignums, always yields a bignum."
+        "Given rationals, always yields a rational."    
     }
 }
 { $see-also "division-by-zero" mod } ;

core/math/math.factor

@@ -66,7 +66,7 @@ PRIVATE>
 
 : ?1+ [ 1+ ] [ 0 ] if* ; inline
 
-: rem ( x y -- z ) tuck mod over + swap mod ; foldable
+: rem ( x y -- z ) abs tuck mod over + swap mod ; foldable
 
 : 2^ ( n -- 2^n ) 1 swap shift ; inline
 

core/math/parser/parser-tests.factor

@@ -101,7 +101,7 @@ unit-test
 
 [ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
 
-[ 0.0/0.0 ] [ "0/0." string>number ] unit-test
+[ t ] [ "0/0." string>number fp-nan? ] unit-test
 
 [ 1.0/0.0 ] [ "1/0." string>number ] unit-test
 

core/sequences/sequences.factor

@@ -326,6 +326,9 @@ M: immutable-sequence clone-like like ;
     >r [ min-length ] 2keep r>
     [ >r 2nth-unsafe r> call ] 3curry ; inline
 
+: 2map-into ( seq1 seq2 quot into -- newseq )
+    >r (2each) r> collect ; inline
+
 : finish-find ( i seq -- i elt )
     over [ dupd nth-unsafe ] [ drop f ] if ; inline
 
@@ -382,12 +385,15 @@ PRIVATE>
     >r -rot r> 2each ; inline
 
 : 2map-as ( seq1 seq2 quot exemplar -- newseq )
-    >r (2each) over r>
+    >r 2over min-length r>
-    [ [ collect ] keep ] new-like ; inline
+    [ [ 2map-into ] keep ] new-like ; inline
 
 : 2map ( seq1 seq2 quot -- newseq )
     pick 2map-as ; inline
 
+: 2change-each ( seq1 seq2 quot -- newseq )
+    pick 2map-into ; inline
+
 : 2all? ( seq1 seq2 quot -- ? )
     (2each) all-integers? ; inline
 

extra/24-game/24-game.factor

@@ -0,0 +1,38 @@
+! Copyright © 2008 Reginald Keith Ford II
+! 24, the Factor game!
+
+USING: kernel random namespaces shuffle sequences
+parser io math prettyprint combinators
+vectors words quotations accessors math.parser
+backtrack math.ranges locals fry memoize macros assocs ;
+
+IN: 24-game
+
+: nop ;
+: do-something ( a b -- c ) { + - * } amb-execute ;
+: maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
+: some-rots ( a b c -- a b c )
+    #! Try each permutation of 3 elements.
+    { nop rot -rot swap spin swapd } amb-execute ;
+: makes-24? ( a b c d -- ? ) [ some-rots do-something some-rots do-something maybe-swap do-something 24 = ] [ 4drop ] if-amb ;
+: vector-24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
+: q ( -- obj ) "quit" ;
+: show-commands ( -- ) "Commands: " write "commands" get unparse print ;
+: report ( vector -- ) unparse print show-commands ;
+: give-help ( -- ) "Command not found..." print show-commands ;
+: find-word ( string choices -- word ) [ name>> = ] with find nip ;
+: obtain-word ( -- word ) readln "commands" get find-word dup [ drop give-help obtain-word ] unless ;
+: done? ( vector -- t/f ) 1 swap length = ;
+: victory? ( vector -- t/f ) V{ 24 } = ;
+: apply-word ( vector word -- vector ) 1quotation with-datastack >vector ;
+: update-commands ( vector -- ) length 3 < [ "commands" [ \ rot swap remove ] change ] [ ] if ;
+DEFER: check-status
+: quit-game ( vector -- ) drop "you're a quitter" print ;
+: quit? ( vector -- t/f ) peek "quit" = ;
+: end-game ( vector -- ) dup victory? [ drop "You WON!" ] [ pop number>string " is not 24... You lose." append ] if print ;
+: repeat ( vector -- ) dup report obtain-word apply-word dup update-commands check-status  ;
+: check-status ( object -- ) dup done? [ end-game ] [ dup quit? [ quit-game ] [ repeat ] if ] if ;
+: build-quad ( -- vector ) 4 [ 10 random ] replicate >vector ;
+: 24-able ( -- vector ) build-quad dup vector-24-able? [ drop build-quad ] unless ;
+: set-commands ( -- ) { + - * / rot swap q } "commands" set ;
+: play-game ( -- ) set-commands 24-able repeat ;

extra/locals/backend/backend.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel slots.private inference.known-words
 inference.backend sequences effects words ;
 IN: locals.backend

extra/math/derivatives/derivatives-docs.factor

@@ -0,0 +1,9 @@
+USING: help.markup help.syntax ;
+
+IN: math.derivatives
+
+HELP: derivative ( x function -- m )
+{ $values { "x" "the x-position on the function" } { "function" "a differentiable function" } }
+{ $description "Finds the slope of the tangent line at the given x-position on the given function." } ;
+
+{ derivative-func } related-words

extra/math/derivatives/derivatives.factor

@@ -0,0 +1,9 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Tool for computing the derivative of a function at a point 
+USING: kernel math math.points math.function-tools ;
+IN: math.derivatives
+
+: small-amount ( -- n ) 1.0e-12 ;
+: near ( x -- y ) small-amount + ;
+: derivative ( x function -- m ) 2dup [ near ] dip [ eval ] 2bi@ slope ;
+: derivative-func ( function -- function ) [ derivative ] curry ;

extra/math/function-tools/function-tools.factor

@@ -0,0 +1,8 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
+
+USING: kernel math arrays ;
+IN: math.function-tools 
+: difference-func ( func func -- func ) [ bi - ] 2curry ;
+: eval ( x func -- pt ) dupd call 2array ;
+: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ;

extra/math/geometry/geometry.factor

@@ -4,5 +4,8 @@ IN: math.geometry
 GENERIC: width  ( object -- width )
 GENERIC: height ( object -- width )
 
+GENERIC# set-width!  1 ( object width  -- object )
+GENERIC# set-height! 1 ( object height -- object )
+
 GENERIC# set-x! 1 ( object x -- object )
 GENERIC# set-y! 1 ( object y -- object )

extra/math/geometry/rect/rect.factor

@@ -45,5 +45,8 @@ M: array rect-dim drop { 0 0 } ;
 M: rect width  ( rect -- width  ) dim>> first  ;
 M: rect height ( rect -- height ) dim>> second ;
 
+M: rect set-width!  ( rect width  -- rect ) over dim>> set-first  ;
+M: rect set-height! ( rect height -- rect ) over dim>> set-second ;
+
 M: rect set-x! ( rect x -- rect ) over loc>> set-first  ;
 M: rect set-y! ( rect y -- rect ) over loc>> set-second ;

extra/math/matrices/elimination/elimination.factor

@@ -11,7 +11,7 @@ SYMBOL: matrix
 
 : nth-row ( row# -- seq ) matrix get nth ;
 
-: change-row ( row# quot -- | quot: seq -- seq )
+: change-row ( row# quot: ( seq -- seq ) -- )
     matrix get swap change-nth ; inline
 
 : exchange-rows ( row# row# -- ) matrix get exchange ;

extra/math/newtons-method/newtons-method.factor

@@ -0,0 +1,11 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Newton's Method of approximating roots
+
+USING: kernel math math.derivatives ;
+IN: math.newtons-method
+
+<PRIVATE
+: newton-step ( x function -- x2 ) dupd [ call ] [ derivative ] 2bi / - ;
+: newton-precision ( -- n ) 7 ;
+PRIVATE>
+: newton-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ;

extra/math/points/points.factor

@@ -1,5 +1,4 @@
-
+USING: kernel arrays math.vectors sequences math ;
-USING: kernel arrays math.vectors ;
 
 IN: math.points
 
@@ -20,3 +19,9 @@ PRIVATE>
 : v+z ( seq z -- seq ) Z v+ ;
 : v-z ( seq z -- seq ) Z v- ;
 
+: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
+: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
+: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
+: distance ( point point -- float ) v- norm ;
+: midpoint ( point point -- point ) v+ 2 v/n ;
+: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;

extra/math/ratios/ratios.factor

@@ -51,5 +51,5 @@ M: ratio * 2>fraction * >r * r> / ;
 M: ratio / scale / ;
 M: ratio /i scale /i ;
 M: ratio /f scale /f ;
-M: ratio mod 2dup >r >r /i r> r> rot * - ;
+M: ratio mod [ /i ] 2keep rot * - ;
 M: ratio /mod [ /i ] 2keep mod ;

extra/math/secant-method/secant-method.factor

@@ -0,0 +1,14 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Secant Method of approximating roots
+
+USING: kernel math math.function-tools math.points math.vectors ;
+IN: math.secant-method
+
+<PRIVATE
+: secant-solution ( x1 x2 function -- solution ) [ eval ] curry bi@ linear-solution ;
+: secant-step ( x1 x2 func -- x2 x3 func ) 2dup [ secant-solution ] 2dip swapd ;
+: secant-precision ( -- n ) 11 ;
+PRIVATE>
+: secant-method ( left right function -- x ) secant-precision [ secant-step ] times drop v+ 2 v*n ;
+! : close-enough? ( a b -- t/f ) - abs tiny-amount < ;
+! : secant-method2 ( left right function -- x ) 2over close-enough? [ drop average ] [ secant-step secant-method ] if  ;

extra/project-euler/ave-time/ave-time.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Aaron Schaefer
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays combinators io kernel math math.functions math.parser
-    math.statistics namespaces sequences tools.time ;
+    math.statistics namespaces sequences tools.time continuations ;
 IN: project-euler.ave-time
 
 : collect-benchmarks ( quot n -- seq )

extra/slides/slides.factor

@@ -3,7 +3,7 @@
 USING: arrays hashtables help.markup help.stylesheet io
 io.styles kernel math models namespaces sequences ui ui.gadgets
 ui.gadgets.books ui.gadgets.panes ui.gestures ui.render
-parser ;
+parser accessors ;
 IN: slides
 
 : stylesheet
@@ -48,10 +48,9 @@ IN: slides
 : $divider ( -- )
     [
         <gadget>
-        T{ gradient f { { 0.25 0.25 0.25 1.0 } { 1.0 1.0 1.0 0.0 } } }
+        T{ gradient f { { 0.25 0.25 0.25 1.0 } { 1.0 1.0 1.0 0.0 } } } >>interior
-        over set-gadget-interior
+        { 800 10 } >>dim
-        { 800 10 } over set-gadget-dim
+        { 1 0 } >>orientation
-        { 1 0 } over set-gadget-orientation
         gadget.
     ] ($block) ;
 

extra/ui/cocoa/views/views.factor

@@ -338,7 +338,7 @@ CLASS: {
 { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
     [
         [
-            2drop dup view-dim swap window set-gadget-dim yield
+            2drop dup view-dim swap window (>>dim) yield
         ] ui-try
     ]
 }

extra/ui/gadgets/books/books.factor

@@ -25,6 +25,6 @@ M: book model-changed ( model book -- )
 M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
 
 M: book layout* ( book -- )
-   [ dim>> ] [ children>> ] bi [ set-layout-dim ] with each ;
+   [ dim>> ] [ children>> ] bi [ (>>dim) ] with each ;
 
 M: book focusable-child* ( book -- child/t ) current-page ;

extra/ui/gadgets/borders/borders.factor

@@ -42,7 +42,7 @@ M: border pref-dim*
 M: border layout*
     dup border-child-rect swap gadget-child
     over loc>> over set-rect-loc
-    swap dim>> swap set-layout-dim ;
+    swap dim>> swap (>>dim) ;
 
 M: border focusable-child*
     gadget-child ;

extra/ui/gadgets/buttons/buttons.factor

@@ -126,7 +126,7 @@ M: checkmark-paint draw-interior
 : <checkmark> ( -- gadget )
     <gadget>
     dup checkmark-theme
-    { 14 14 } over set-gadget-dim ;
+    { 14 14 } over (>>dim) ;
 
 : toggle-model ( model -- )
     [ not ] change-model ;
@@ -172,7 +172,7 @@ M: radio-paint draw-boundary
 : <radio-knob> ( -- gadget )
     <gadget>
     dup radio-knob-theme
-    { 16 16 } over set-gadget-dim ;
+    { 16 16 } over (>>dim) ;
 
 TUPLE: radio-control < button value ;
 

extra/ui/gadgets/gadgets-docs.factor

@@ -65,16 +65,6 @@ HELP: relayout-1
 
 { relayout relayout-1 } related-words
 
-HELP: set-layout-dim
-{ $values { "dim" "a pair of integers" } { "gadget" gadget } }
-{ $description "Resizes a gadget inside a " { $link layout* } " method." }
-{ $warning "Do not call this word outside of a " { $link layout* } " method, or otherwise the gadget will not be relayout automatically. Instead, use " { $link set-gadget-dim } "." } ;
-
-HELP: set-gadget-dim
-{ $values { "dim" "a pair of integers" } { "gadget" gadget } }
-{ $description "Resizes and relayouts a gadget before the next iteration of the event loop." }
-{ $warning "Do not call this word inside a " { $link layout* } " method, or otherwise unnecessary work will be done by the UI to ensure the gadget is relayout. Instead, use " { $link set-layout-dim } "." } ;
-
 HELP: pref-dim*
 { $values { "gadget" gadget } { "dim" "a pair of integers" } }
 { $contract "Outputs the preferred dimensions of the gadget, possibly computing them from the preferred dimensions of the gadget's children." }

extra/ui/gadgets/gadgets.factor

@@ -165,16 +165,16 @@ DEFER: relayout
 
 : hide-gadget ( gadget -- ) f swap (>>visible?) ;
 
-: (set-rect-dim) ( dim gadget quot -- )
+DEFER: in-layout?
-    >r 2dup rect-dim =
-    [ [ 2drop ] [ set-rect-dim ] if ] 2keep
-    [ drop ] r> if ; inline
 
-: set-layout-dim ( dim gadget -- )
+: do-invalidate ( gadget -- gadget )
-    [ invalidate ] (set-rect-dim) ;
+  in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
 
-: set-gadget-dim ( dim gadget -- )
+M: gadget (>>dim) ( dim gadget -- )
-    [ invalidate* ] (set-rect-dim) ;
+   2dup dim>> =
+     [ 2drop ]
+     [ tuck call-next-method do-invalidate drop ]
+   if ;
 
 GENERIC: pref-dim* ( gadget -- dim )
 
@@ -195,7 +195,7 @@ GENERIC: layout* ( gadget -- )
 
 M: gadget layout* drop ;
 
-: prefer ( gadget -- ) dup pref-dim swap set-layout-dim ;
+: prefer ( gadget -- ) dup pref-dim swap (>>dim) ;
 
 : validate ( gadget -- ) f swap (>>layout-state) ;
 

extra/ui/gadgets/grids/grids.factor

@@ -66,7 +66,7 @@ M: grid pref-dim*
 
 : resize-grid ( grid horiz vert -- )
     pick grid-fill? [
-        pair-up swap [ set-layout-dim ] do-grid
+        pair-up swap [ (>>dim) ] do-grid
     ] [
         2drop grid>> [ [ prefer ] each ] each
     ] if ;

extra/ui/gadgets/packs/packs.factor

@@ -31,7 +31,7 @@ TUPLE: pack < gadget
 
 : pack-layout ( pack sizes -- )
     round-dims over gadget-children
-    >r dupd packed-dims r> 2dup [ set-layout-dim ] 2each
+    >r dupd packed-dims r> 2dup [ (>>dim) ] 2each
     >r packed-locs r> [ set-rect-loc ] 2each ;
 
 : <pack> ( orientation -- pack )

extra/ui/gadgets/sliders/sliders.factor

@@ -110,7 +110,7 @@ elevator H{
     dup dup thumb-dim (layout-thumb) >r
     >r dup rect-dim r>
     rot gadget-orientation set-axis [ ceiling ] map
-    r> set-layout-dim ;
+    r> (>>dim) ;
 
 : layout-thumb ( slider -- )
     dup layout-thumb-loc layout-thumb-dim ;

extra/ui/gadgets/tiling/tiling.factor

@@ -0,0 +1,153 @@
+
+USING: kernel sequences math math.order
+       ui.gadgets ui.gadgets.tracks ui.gestures
+       fry accessors ;
+
+IN: ui.gadgets.tiling
+
+TUPLE: tiling < track gadgets tiles first focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-tiling ( tiling -- tiling )
+  init-track
+  { 1 0 }    >>orientation
+  V{ } clone >>gadgets
+  2          >>tiles
+  0          >>first
+  0          >>focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <tiling> ( -- gadget ) tiling new init-tiling ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bounded-subseq ( seq a b -- seq )
+  [ 0 max ] dip
+  pick length [ min ] curry bi@
+  rot
+  subseq ;
+
+: tiling-gadgets-to-map ( tiling -- gadgets )
+  [ gadgets>> ]
+  [ first>> ]
+  [ [ first>> ] [ tiles>> ] bi + ]
+  tri
+  bounded-subseq ;
+
+: tiling-map-gadgets ( tiling -- tiling )
+  dup clear-track
+  dup tiling-gadgets-to-map [ 1 track-add* ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: tiling-add ( tiling gadget -- tiling )
+  over gadgets>> push
+  tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: first-gadget ( tiling -- index ) drop 0 ;
+
+: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
+
+: first-viewable ( tiling -- index ) first>> ;
+
+: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-focused-mapped ( tiling -- tiling )
+
+  dup [ focused>> ] [ first>> ] bi <
+    [ dup first>> 1 - >>first ]
+    [ ]
+  if
+
+  dup [ last-viewable ] [ focused>> ] bi <
+    [ dup first>> 1 + >>first ]
+    [ ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-focused-bounds ( tiling -- tiling )
+  dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
+
+: focus-prev ( tiling -- tiling )
+  dup focused>> 1 - >>focused
+  check-focused-bounds
+  make-focused-mapped
+  tiling-map-gadgets
+  dup request-focus ;
+
+: focus-next ( tiling -- tiling )
+  dup focused>> 1 + >>focused
+  check-focused-bounds
+  make-focused-mapped
+  tiling-map-gadgets
+  dup request-focus ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: exchanged! ( seq a b -- )
+                   [ 0 max ] bi@
+  pick length 1 - '[ , min ] bi@
+  rot exchange ;
+
+: move-prev ( tiling -- tiling )
+  dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
+  focus-prev ;
+
+: move-next ( tiling -- tiling )
+  dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
+  focus-next ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-tile ( tiling -- tiling )
+  dup tiles>> 1 + >>tiles
+  tiling-map-gadgets ;
+
+: del-tile ( tiling -- tiling )
+  dup tiles>> 1 - 1 max >>tiles
+  tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: tiling focusable-child* ( tiling -- child/t )
+   [ focused>> ] [ gadgets>> ] bi nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling-shelf < tiling ;
+TUPLE: tiling-pile  < tiling ;
+
+: <tiling-shelf> ( -- gadget )
+  tiling-shelf new init-tiling { 1 0 } >>orientation ;
+
+: <tiling-pile> ( -- gadget )
+  tiling-pile new init-tiling { 0 1 } >>orientation ;
+
+tiling-shelf
+ H{
+    { T{ key-down f { A+    } "LEFT"  } [ focus-prev  drop ] }
+    { T{ key-down f { A+    } "RIGHT" } [ focus-next drop ] }
+    { T{ key-down f { S+ A+ } "LEFT"  } [ move-prev   drop ] }
+    { T{ key-down f { S+ A+ } "RIGHT" } [ move-next  drop ] }
+    { T{ key-down f { C+    } "["     } [ del-tile  drop ] }
+    { T{ key-down f { C+    } "]"     } [ add-tile  drop ] }
+  }
+set-gestures
+
+tiling-pile
+ H{
+    { T{ key-down f { A+    } "UP"  } [ focus-prev  drop ] }
+    { T{ key-down f { A+    } "DOWN" } [ focus-next drop ] }
+    { T{ key-down f { S+ A+ } "UP"  } [ move-prev   drop ] }
+    { T{ key-down f { S+ A+ } "DOWN" } [ move-next  drop ] }
+    { T{ key-down f { C+    } "["     } [ del-tile  drop ] }
+    { T{ key-down f { C+    } "]"     } [ add-tile  drop ] }
+  }
+set-gestures

extra/ui/gadgets/tracks/tracks.factor

@@ -11,11 +11,15 @@ TUPLE: track < pack sizes ;
 : normalized-sizes ( track -- seq )
   sizes>> dup sift sum '[ dup [ , / ] when ] map ;
 
-: new-track ( orientation class -- track )
+: init-track ( track -- track )
-  new-gadget
+  init-gadget
-    swap       >>orientation
   V{ } clone >>sizes
-    1          >>fill ; inline
+  1          >>fill ;
+
+: new-track ( orientation class -- track )
+  new
+    init-track
+    swap >>orientation ;
 
 : <track> ( orientation -- track ) track new-track ;
 

extra/ui/gadgets/viewports/viewports.factor

@@ -23,7 +23,7 @@ TUPLE: viewport < gadget ;
 M: viewport layout*
     dup rect-dim viewport-gap 2 v*n v-
     over gadget-child pref-dim vmax
-    swap gadget-child set-layout-dim ;
+    swap gadget-child (>>dim) ;
 
 M: viewport focusable-child*
     gadget-child ;

extra/ui/gadgets/worlds/worlds.factor

@@ -46,7 +46,7 @@ M: world request-focus-on ( child gadget -- )
 M: world layout*
     dup call-next-method
     dup world-glass [
-        >r dup rect-dim r> set-layout-dim
+        >r dup rect-dim r> (>>dim)
     ] when* drop ;
 
 M: world focusable-child* gadget-child ;

extra/ui/gadgets/wrappers/wrappers.factor

@@ -12,7 +12,6 @@ TUPLE: wrapper < gadget ;
 
 M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
 
-M: wrapper layout* ( wrapper -- )
+M: wrapper layout* ( wrapper -- ) [ dim>> ] [ gadget-child ] bi (>>dim) ;
-    [ dim>> ] [ gadget-child ] bi set-layout-dim ;
 
 M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;

extra/ui/ui-docs.factor

@@ -236,15 +236,13 @@ $nl
 
 ARTICLE: "ui-null-layout" "Manual layouts"
 "When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
-{ $subsection set-rect-loc }
+{ $subsection set-rect-loc } ;
-{ $subsection set-gadget-dim } ;
 
 ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
 "The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:"
 { $subsection layout* }
 "When a " { $link layout* } " method is called, the size and location of the gadget has already been determined by its parent, and the method's job is to lay out the gadget's children. Children can be positioned and resized with a pair of words:"
 { $subsection set-rect-loc }
-{ $subsection set-layout-dim }
 "Some assorted utility words which are useful for implementing layout logic:"
 { $subsection pref-dim }
 { $subsection pref-dims }

extra/ui/ui.factor

@@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
 prettyprint dlists dequeues sequences threads sequences words
 debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
 ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.flags sets ;
+hashtables concurrency.flags sets accessors ;
 IN: ui
 
 ! Assoc mapping aliens to gadgets
@@ -172,7 +172,7 @@ SYMBOL: ui-thread
     "UI update" spawn drop ;
 
 : open-world-window ( world -- )
-    dup pref-dim over set-gadget-dim dup relayout graft ;
+    dup pref-dim over (>>dim) dup relayout graft ;
 
 : open-window ( gadget title -- )
     f <world> open-world-window ;

extra/ui/windows/windows.factor

@@ -93,7 +93,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
 : handle-wm-size ( hWnd uMsg wParam lParam -- )
     2nip
     [ lo-word ] keep hi-word 2array
-    dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
+    dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
 
 : handle-wm-move ( hWnd uMsg wParam lParam -- )
     2nip

extra/ui/x11/x11.factor

@@ -22,7 +22,7 @@ M: world expose-event nip relayout ;
 
 M: world configure-event
     over configured-loc over (>>window-loc)
-    swap configured-dim over set-gadget-dim
+    swap configured-dim over (>>dim)
     ! In case dimensions didn't change
     relayout-1 ;
 

unfinished/compiler/frontend/frontend-tests.factor

@@ -1,17 +0,0 @@
-
-
-[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
-[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
-
-USE: inference.dataflow
-
-{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
-
-{ 1 0 }
-[
-    [ [ iterate-next ] iterate-nodes ] with-node-iterator
-] must-infer-as
-
-{ 1 0 } [ [ drop ] each-node ] must-infer-as
-
-{ 1 0 } [ [ ] map-children ] must-infer-as

unfinished/compiler/frontend/frontend.factor

@@ -1,79 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors quotations kernel sequences namespaces assocs
-words generic generic.standard generic.standard.engines arrays
-kernel.private combinators vectors stack-checker
-stack-checker.state stack-checker.visitor stack-checker.errors
-stack-checker.backend compiler.tree.builder ;
-IN: compiler.frontend
-
-: with-dataflow ( quot -- dataflow )
-    [ tree-builder new dataflow-visitor set ] prepose
-    with-infer first>> ; inline
-
-GENERIC# dataflow-with 1 ( quot stack -- dataflow )
-
-M: callable dataflow-with
-    #! Not safe to call from inference transforms.
-    [
-        >vector meta-d set
-        f infer-quot
-    ] with-dataflow nip ;
-
-: dataflow ( quot -- dataflow ) f dataflow-with ;
-
-: (make-specializer) ( class picker -- quot )
-    swap "predicate" word-prop append ;
-
-: make-specializer ( classes -- quot )
-    dup length <reversed>
-    [ (picker) 2array ] 2map
-    [ drop object eq? not ] assoc-filter
-    dup empty? [ drop [ t ] ] [
-        [ (make-specializer) ] { } assoc>map
-        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
-    ] if ;
-
-: specializer-cases ( quot word -- default alist )
-    dup [ array? ] all? [ 1array ] unless [
-        [ make-specializer ] keep
-        '[ , declare ] pick append
-    ] { } map>assoc ;
-
-: method-declaration ( method -- quot )
-    dup "method-generic" word-prop dispatch# object <array>
-    swap "method-class" word-prop prefix ;
-
-: specialize-method ( quot method -- quot' )
-    method-declaration '[ , declare ] prepend ;
-
-: specialize-quot ( quot specializer -- quot' )
-    specializer-cases alist>quot ;
-
-: standard-method? ( method -- ? )
-    dup method-body? [
-        "method-generic" word-prop standard-generic?
-    ] [ drop f ] if ;
-
-: specialized-def ( word -- quot )
-    dup def>> swap {
-        { [ dup standard-method? ] [ specialize-method ] }
-        {
-            [ dup "specializer" word-prop ]
-            [ "specializer" word-prop specialize-quot ]
-        }
-        [ drop ]
-    } cond ;
-
-: word-dataflow ( word -- effect dataflow )
-    [
-        [
-            dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
-            dup "no-compile" word-prop [ cannot-infer-effect ] when
-            dup specialized-def over dup 2array 1array infer-quot
-            finish-word
-        ] maybe-cannot-infer
-    ] with-dataflow ;
-
-: specialized-length ( specializer -- n )
-    dup [ array? ] all? [ first ] when length ;

unfinished/compiler/tree/builder/builder-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax sequences quotations words 
 compiler.tree stack-checker.errors ;
-IN: compiler.frontend
+IN: compiler.tree.builder
 
 ARTICLE: "specializers" "Word specializers"
 "The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
@@ -22,15 +22,15 @@ $nl
 "The specialized version of a word which will be compiled by the compiler can be inspected:"
 { $subsection specialized-def } ;
 
-HELP: dataflow
+HELP: build-tree
 { $values { "quot" quotation } { "dataflow" node } }
-{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
+{ $description "Attempts to construct tree SSA IR from a quotation." }
 { $notes "This is the first stage of the compiler." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
-HELP: dataflow-with
+HELP: build-tree-with
 { $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
-{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
+{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
 HELP: specialized-def

unfinished/compiler/tree/builder/builder-tests.factor

@@ -0,0 +1,6 @@
+IN: compiler.tree.builder.tests
+USING: compiler.tree.builder tools.test ;
+
+\ build-tree must-infer
+\ build-tree-with must-infer
+\ build-tree-from-word must-infer

unfinished/compiler/tree/builder/builder.factor

@@ -1,32 +1,79 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel sequences compiler.tree
+USING: fry accessors quotations kernel sequences namespaces assocs
-stack-checker.visitor ;
+words generic generic.standard generic.standard.engines arrays
+kernel.private combinators vectors stack-checker
+stack-checker.state stack-checker.visitor stack-checker.errors
+stack-checker.backend compiler.tree ;
 IN: compiler.tree.builder
 
-TUPLE: tree-builder first last ;
+: with-tree-builder ( quot -- dataflow )
+    [ node-list new stack-visitor set ] prepose
+    with-infer first>> ; inline
 
-: node, ( node -- )
+GENERIC# build-tree-with 1 ( quot stack -- dataflow )
-    dataflow-visitor get swap
-    over last>>
-    [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
-    [ [ >>first ] [ >>last ] bi drop ]
-    if ;
 
-M: tree-builder child-visitor tree-builder new ;
+M: callable build-tree-with
-M: tree-builder #introduce, #introduce node, ;
+    #! Not safe to call from inference transforms.
-M: tree-builder #call, #call node, ;
+    [
-M: tree-builder #call-recursive, #call-recursive node, ;
+        >vector meta-d set
-M: tree-builder #push, #push node, ;
+        f infer-quot
-M: tree-builder #shuffle, #shuffle node, ;
+    ] with-tree-builder nip ;
-M: tree-builder #drop, #drop node, ;
+
-M: tree-builder #>r, #>r node, ;
+: build-tree ( quot -- dataflow ) f build-tree-with ;
-M: tree-builder #r>, #r> node, ;
+
-M: tree-builder #return, #return node, ;
+: (make-specializer) ( class picker -- quot )
-M: tree-builder #terminate, #terminate node, ;
+    swap "predicate" word-prop append ;
-M: tree-builder #if, [ first>> ] bi@ #if node, ;
+
-M: tree-builder #dispatch, [ first>> ] map #dispatch node, ;
+: make-specializer ( classes -- quot )
-M: tree-builder #phi, #phi node, ;
+    dup length <reversed>
-M: tree-builder #declare, #declare node, ;
+    [ (picker) 2array ] 2map
-M: tree-builder #recursive, first>> #recursive node, ;
+    [ drop object eq? not ] assoc-filter
-M: tree-builder #copy, #copy node, ;
+    dup empty? [ drop [ t ] ] [
+        [ (make-specializer) ] { } assoc>map
+        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+    ] if ;
+
+: specializer-cases ( quot word -- default alist )
+    dup [ array? ] all? [ 1array ] unless [
+        [ make-specializer ] keep
+        '[ , declare ] pick append
+    ] { } map>assoc ;
+
+: method-declaration ( method -- quot )
+    dup "method-generic" word-prop dispatch# object <array>
+    swap "method-class" word-prop prefix ;
+
+: specialize-method ( quot method -- quot' )
+    method-declaration '[ , declare ] prepend ;
+
+: specialize-quot ( quot specializer -- quot' )
+    specializer-cases alist>quot ;
+
+: standard-method? ( method -- ? )
+    dup method-body? [
+        "method-generic" word-prop standard-generic?
+    ] [ drop f ] if ;
+
+: specialized-def ( word -- quot )
+    dup def>> swap {
+        { [ dup standard-method? ] [ specialize-method ] }
+        {
+            [ dup "specializer" word-prop ]
+            [ "specializer" word-prop specialize-quot ]
+        }
+        [ drop ]
+    } cond ;
+
+: build-tree-from-word ( word -- effect dataflow )
+    [
+        [
+            dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
+            dup "no-compile" word-prop [ cannot-infer-effect ] when
+            dup specialized-def over dup 2array 1array infer-quot
+            finish-word
+        ] maybe-cannot-infer
+    ] with-tree-builder ;
+
+: specialized-length ( specializer -- n )
+    dup [ array? ] all? [ first ] when length ;

unfinished/compiler/tree/combinators/combinators-tests.factor

@@ -0,0 +1,17 @@
+IN: compiler.tree.combinators.tests
+USING: compiler.tree.combinators compiler.tree.builder tools.test
+kernel ;
+
+[ ] [ [ 1 ] build-tree [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] build-tree [ ] transform-nodes drop ] unit-test
+
+{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
+
+{ 1 0 }
+[
+    [ [ iterate-next ] iterate-nodes ] with-node-iterator
+] must-infer-as
+
+{ 1 0 } [ [ drop ] each-node ] must-infer-as
+
+{ 1 0 } [ [ ] map-children ] must-infer-as

unfinished/compiler/tree/combinators/combinators.factor

@@ -5,18 +5,6 @@ sequences words vectors math.intervals effects classes
 accessors combinators compiler.tree ;
 IN: compiler.tree.combinators
 
-: node-exists? ( node quot -- ? )
-    over [
-        2dup 2slip rot [
-            2drop t
-        ] [
-            [ [ children>> ] [ successor>> ] bi suffix ] dip
-            '[ , node-exists? ] contains?
-        ] if
-    ] [
-        2drop f
-    ] if ; inline
-
 SYMBOL: node-stack
 
 : >node ( node -- ) node-stack get push ;
@@ -34,8 +22,8 @@ SYMBOL: node-stack
 
 : (each-node) ( quot -- next )
     node@ [ swap call ] 2keep
-    node-children [
+    children>> [
-        [
+        first>> [
             [ (each-node) ] keep swap
         ] iterate-nodes
     ] each drop
@@ -52,15 +40,7 @@ SYMBOL: node-stack
     ] with-node-iterator ; inline
 
 : map-children ( node quot -- )
-    over [
+    [ children>> ] dip '[ , change-first drop ] each ; inline
-        over children>> [
-            '[ , map ] change-children drop
-        ] [
-            2drop
-        ] if
-    ] [
-        2drop
-    ] if ; inline
 
 : (transform-nodes) ( prev node quot -- )
     dup >r call dup [

unfinished/compiler/tree/comparisons/comparisons.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.order math.intervals assocs combinators ;
+IN: compiler.tree.comparisons
+
+! Some utilities for working with comparison operations.
+
+: comparison-ops { < > <= >= } ;
+
+: generic-comparison-ops { before? after? before=? after=? } ;
+
+: assumption ( i1 i2 op -- i3 )
+    {
+        { \ <  [ assume< ] }
+        { \ >  [ assume> ] }
+        { \ <= [ assume<= ] }
+        { \ >= [ assume>= ] }
+    } case ;
+
+: interval-comparison ( i1 i2 op -- result )
+    {
+        { \ <  [ interval< ] }
+        { \ >  [ interval> ] }
+        { \ <= [ interval<= ] }
+        { \ >= [ interval>= ] }
+    } case ;
+
+: swap-comparison ( op -- op' )
+    {
+        { < > }
+        { > < }
+        { <= >= }
+        { >= <= }
+    } at ;
+
+: negate-comparison ( op -- op' )
+    {
+        { < >= }
+        { > <= }
+        { <= > }
+        { >= < }
+    } at ;
+
+: specific-comparison ( op -- op' )
+    {
+        { before? < }
+        { after? > }
+        { before=? <= }
+        { after=? >= }
+    } at ;

unfinished/compiler/tree/copy-equiv/copy-equiv.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces disjoint-sets sequences assocs
+kernel accessors fry
+compiler.tree compiler.tree.def-use compiler.tree.combinators ;
+IN: compiler.tree.copy-equiv
+
+! Disjoint set of copy equivalence
+SYMBOL: copies
+
+: is-copy-of ( val copy -- ) copies get equate ;
+
+: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+
+: resolve-copy ( copy -- val ) copies get representative ;
+
+: introduce-value ( val -- ) copies get add-atom ;
+
+GENERIC: compute-copy-equiv* ( node -- )
+
+M: #shuffle compute-copy-equiv*
+    [ out-d>> dup ] [ mapping>> ] bi
+    '[ , at ] map swap are-copies-of ;
+
+M: #>r compute-copy-equiv*
+    [ in-d>> ] [ out-r>> ] bi are-copies-of ;
+
+M: #r> compute-copy-equiv*
+    [ in-r>> ] [ out-d>> ] bi are-copies-of ;
+
+M: #copy compute-copy-equiv*
+    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
+
+M: node compute-copy-equiv* drop ;
+
+: compute-copy-equiv ( node -- node )
+    <disjoint-set> copies set
+    dup [
+        [ node-defs-values [ introduce-value ] each ]
+        [ compute-copy-equiv* ]
+        bi
+    ] each-node ;

unfinished/compiler/tree/dead-code/dead-code-tests.factor

@@ -1,4 +1,4 @@
-USING: namespaces assocs sequences compiler.frontend
+USING: namespaces assocs sequences compiler.tree.builder
 compiler.tree.dead-code compiler.tree.def-use compiler.tree
 compiler.tree.combinators tools.test kernel math
 stack-checker.state accessors ;
@@ -7,7 +7,7 @@ IN: compiler.tree.dead-code.tests
 \ remove-dead-code must-infer
 
 : count-live-values ( quot -- n )
-    dataflow
+    build-tree
     compute-def-use
     remove-dead-code
     compute-def-use

unfinished/compiler/tree/dead-code/dead-code.factor

@@ -1,106 +1,44 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors namespaces assocs dequeues search-dequeues
-kernel sequences words sets stack-checker.inlining compiler.tree
+kernel sequences words sets stack-checker.inlining
-compiler.tree.combinators compiler.tree.def-use ;
+compiler.tree
+compiler.tree.dfa
+compiler.tree.dfa.backward
+compiler.tree.combinators ;
 IN: compiler.tree.dead-code
 
 ! Dead code elimination: remove #push and flushable #call whose
-! outputs are unused.
+! outputs are unused using backward DFA.
-
-SYMBOL: live-values
-SYMBOL: work-list
-
-: live-value? ( value -- ? )
-    live-values get at ;
-
-: look-at-value ( values -- )
-    work-list get push-front ;
-
-: look-at-values ( values -- )
-    work-list get '[ , push-front ] each ;
-
 GENERIC: mark-live-values ( node -- )
 
-: look-at-inputs ( node -- ) in-d>> look-at-values ;
-
-: look-at-outputs ( node -- ) out-d>> look-at-values ;
-
-M: #introduce mark-live-values look-at-outputs ;
-
 M: #if mark-live-values look-at-inputs ;
 
 M: #dispatch mark-live-values look-at-inputs ;
 
 M: #call mark-live-values
-    dup word>> "flushable" word-prop [ drop ] [
+    dup word>> "flushable" word-prop
-        [ look-at-inputs ]
+    [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
-        [ look-at-outputs ]
-        bi
-    ] if ;
 
 M: #return mark-live-values
     #! Values returned by local #recursive functions can be
     #! killed if they're unused.
-    dup label>>
+    dup label>> [ drop ] [ look-at-inputs ] if ;
-    [ drop ] [ look-at-inputs ] if ;
 
 M: node mark-live-values drop ;
 
-GENERIC: propagate* ( value node -- )
+SYMBOL: live-values
 
-M: #copy propagate*
+: live-value? ( value -- ? ) live-values get at ;
-    #! If the output of a copy is live, then the corresponding
-    #! input is live also.
-    [ out-d>> index ] keep in-d>> nth look-at-value ;
-
-M: #call propagate*
-    #! If any of the outputs of a call are live, then all
-    #! inputs and outputs must be live.
-    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
-
-M: #call-recursive propagate*
-    #! If the output of a copy is live, then the corresponding
-    #! inputs to #return nodes are live also.
-    [ out-d>> <reversed> index ] keep label>> returns>>
-    [ <reversed> nth look-at-value ] with each ;
-
-M: #>r propagate* nip in-d>> first look-at-value ;
-
-M: #r> propagate* nip in-r>> first look-at-value ;
-
-M: #shuffle propagate* mapping>> at look-at-value ;
-
-: look-at-corresponding ( value inputs outputs -- )
-    [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
-
-M: #phi propagate*
-    #! If any of the outputs of a #phi are live, then the
-    #! corresponding inputs are live too.
-    [ [ out-d>> ] [ phi-in-d>> flip ] bi look-at-corresponding ]
-    [ [ out-r>> ] [ phi-in-r>> flip ] bi look-at-corresponding ]
-    2bi ;
-
-M: node propagate* 2drop ;
-
-: propogate-liveness ( value -- )
-    live-values get 2dup key? [
-        2drop
-    ] [
-        dupd conjoin
-        dup defined-by propagate*
-    ] if ;
 
 : compute-live-values ( node -- )
-    #! We add f initially because #phi nodes can have f in their
+    [ mark-live-values ] backward-dfa live-values set ;
-    #! inputs.
-    <hashed-dlist> work-list set
-    H{ { f f } } clone live-values set
-    [ mark-live-values ] each-node
-    work-list get [ propogate-liveness ] slurp-dequeue ;
 
 GENERIC: remove-dead-values* ( node -- )
 
+M: #introduce remove-dead-values*
+    [ [ live-value? ] filter ] change-values drop ;
+
 M: #>r remove-dead-values*
     dup out-r>> first live-value? [ { } >>out-r ] unless
     dup in-d>> first live-value? [ { } >>in-d ] unless
@@ -118,13 +56,6 @@ M: #push remove-dead-values*
 : filter-corresponding-values ( in out -- in' out' )
     zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
 
-: remove-dead-copies ( node -- )
-    dup
-    [ in-d>> ] [ out-d>> ] bi
-    filter-corresponding-values
-    [ >>in-d ] [ >>out-d ] bi*
-    drop ;
-
 : filter-live ( values -- values' )
     [ live-value? ] filter ;
 
@@ -133,21 +64,28 @@ M: #shuffle remove-dead-values*
     [ filter-live ] change-out-d
     drop ;
 
-M: #declare remove-dead-values* remove-dead-copies ;
+M: #declare remove-dead-values*
+    [ [ drop live-value? ] assoc-filter ] change-declaration
+    drop ;
 
-M: #copy remove-dead-values* remove-dead-copies ;
+M: #copy remove-dead-values*
+    dup
+    [ in-d>> ] [ out-d>> ] bi
+    filter-corresponding-values
+    [ >>in-d ] [ >>out-d ] bi*
+    drop ;
 
 : remove-dead-phi-d ( #phi -- #phi )
     dup
-    [ phi-in-d>> flip ] [ out-d>> ] bi
+    [ phi-in-d>> ] [ out-d>> ] bi
     filter-corresponding-values
-    [ flip >>phi-in-d ] [ >>out-d ] bi* ;
+    [ >>phi-in-d ] [ >>out-d ] bi* ;
 
 : remove-dead-phi-r ( #phi -- #phi )
     dup
-    [ phi-in-r>> flip ] [ out-r>> ] bi
+    [ phi-in-r>> ] [ out-r>> ] bi
     filter-corresponding-values
-    [ flip >>phi-in-r ] [ >>out-r ] bi* ;
+    [ >>phi-in-r ] [ >>out-r ] bi* ;
 
 M: #phi remove-dead-values*
     remove-dead-phi-d
@@ -156,46 +94,54 @@ M: #phi remove-dead-values*
 
 M: node remove-dead-values* drop ;
 
+M: f remove-dead-values* drop ;
+
 GENERIC: remove-dead-nodes* ( node -- newnode/t )
 
+: prune-if-empty ( node seq -- successor/t )
+    empty? [ successor>> ] [ drop t ] if ; inline
+
+M: #introduce remove-dead-nodes* dup values>> prune-if-empty ;
+
 : live-call? ( #call -- ? )
     out-d>> [ live-value? ] contains? ;
 
+M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
+
 M: #call remove-dead-nodes*
     dup live-call? [ drop t ] [
         [ in-d>> #drop ] [ successor>> ] bi >>successor
     ] if ;
 
-: prune-if ( node quot -- successor/t )
+M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
-    over >r call [ r> successor>> ] [ r> drop t ] if ;
-    inline
 
-M: #shuffle remove-dead-nodes* 
+M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
-    [ in-d>> empty? ] prune-if ;
 
-M: #push remove-dead-nodes*
+M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
-    [ out-d>> empty? ] prune-if ;
 
-M: #>r remove-dead-nodes*
+M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
-    [ in-d>> empty? ] prune-if ;
 
-M: #r> remove-dead-nodes*
+M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
-    [ in-r>> empty? ] prune-if ;
+
+: (remove-dead-code) ( node -- newnode )
+    [
+        dup remove-dead-values*
+        dup remove-dead-nodes* dup t eq?
+        [ drop ] [ nip (remove-dead-code) ] if
+    ] transform-nodes ;
+
+M: #if remove-dead-nodes*
+    [ (remove-dead-code) ] map-children t ;
+
+M: #dispatch remove-dead-nodes*
+    [ (remove-dead-code) ] map-children t ;
+
+M: #recursive remove-dead-nodes*
+    [ (remove-dead-code) ] change-child drop t ;
 
 M: node remove-dead-nodes* drop t ;
 
-: (remove-dead-code) ( node -- newnode )
+M: f remove-dead-nodes* drop t ;
-    dup [
-        dup remove-dead-values*
-        dup remove-dead-nodes* dup t eq? [
-            drop dup [ (remove-dead-code) ] map-children
-        ] [
-            nip (remove-dead-code)
-        ] if
-    ] when ;
 
 : remove-dead-code ( node -- newnode )
-    [
+    [ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
-        [ compute-live-values ]
-        [ [ (remove-dead-code) ] transform-nodes ] bi
-    ] with-scope ;

unfinished/compiler/tree/def-use/def-use-tests.factor

@@ -1,13 +1,13 @@
 USING: accessors namespaces assocs kernel sequences math
 tools.test words sets combinators.short-circuit
-stack-checker.state compiler.tree compiler.frontend
+stack-checker.state compiler.tree compiler.tree.builder
 compiler.tree.def-use arrays kernel.private ;
 IN: compiler.tree.def-use.tests
 
 \ compute-def-use must-infer
 
 [ t ] [
-    [ 1 2 3 ] dataflow compute-def-use drop
+    [ 1 2 3 ] build-tree compute-def-use drop
     def-use get {
         [ assoc-size 3 = ]
         [ values [ uses>> [ #return? ] all? ] all? ]
@@ -29,5 +29,5 @@ IN: compiler.tree.def-use.tests
     [ [ 1 ] [ call 2 ] curry call + ]
     [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
 } [
-    [ ] swap [ dataflow compute-def-use drop ] curry unit-test
+    [ ] swap [ build-tree compute-def-use drop ] curry unit-test
 ] each

unfinished/compiler/tree/def-use/def-use.factor

@@ -28,8 +28,11 @@ TUPLE: definition value node uses ;
 
 GENERIC: node-uses-values ( node -- values )
 
+M: #declare node-uses-values declaration>> keys ;
+
 M: #phi node-uses-values
-    [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi append ;
+    [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
+    append sift prune ;
 
 M: #r> node-uses-values in-r>> ;
 
@@ -41,14 +44,13 @@ M: #introduce node-defs-values values>> ;
 
 M: #>r node-defs-values out-r>> ;
 
+M: #phi node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
+
 M: node node-defs-values out-d>> ;
 
-: each-value ( node values quot -- )
-    [ sift ] dip with each ; inline
-
 : node-def-use ( node -- )
-    [ dup node-uses-values [ use-value ] each-value ]
+    [ dup node-uses-values [ use-value ] with each ]
-    [ dup node-defs-values [ def-value ] each-value ] bi ;
+    [ dup node-defs-values [ def-value ] with each ] bi ;
 
 : check-def-use ( -- )
     def-use get [

unfinished/compiler/tree/dfa/backward/backward.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.dfa.backward
+USING: accessors sequences assocs kernel compiler.tree
+compiler.tree.dfa ;
+
+GENERIC: backward ( value node -- )
+
+M: #copy backward
+    #! If the output of a copy is live, then the corresponding
+    #! input is live also.
+    [ out-d>> index ] keep in-d>> nth look-at-value ;
+
+M: #call backward
+    #! If any of the outputs of a call are live, then all
+    #! inputs and outputs must be live.
+    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #call-recursive backward
+    #! If the output of a copy is live, then the corresponding
+    #! inputs to #return nodes are live also.
+    [ out-d>> <reversed> index ] keep label>> returns>>
+    [ <reversed> nth look-at-value ] with each ;
+
+M: #>r backward nip in-d>> first look-at-value ;
+
+M: #r> backward nip in-r>> first look-at-value ;
+
+M: #shuffle backward mapping>> at look-at-value ;
+
+M: #phi backward
+    #! If any of the outputs of a #phi are live, then the
+    #! corresponding inputs are live too.
+    [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
+    [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
+    2bi ;
+
+M: node backward 2drop ;
+
+: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline

unfinished/compiler/tree/dfa/dfa.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors namespaces assocs dequeues search-dequeues
+kernel sequences words sets stack-checker.inlining compiler.tree
+compiler.tree.def-use compiler.tree.combinators ;
+IN: compiler.tree.dfa
+
+! Dataflow analysis
+SYMBOL: work-list
+
+: look-at-value ( values -- )
+    work-list get push-front ;
+
+: look-at-values ( values -- )
+    work-list get '[ , push-front ] each ;
+
+: look-at-inputs ( node -- ) in-d>> look-at-values ;
+
+: look-at-outputs ( node -- ) out-d>> look-at-values ;
+
+: look-at-corresponding ( value inputs outputs -- )
+    [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
+
+: init-dfa ( -- )
+    #! We add f initially because #phi nodes can have f in their
+    #! inputs.
+    <hashed-dlist> work-list set ;
+
+: iterate-dfa ( value assoc quot -- )
+    2over key? [
+        3drop
+    ] [
+        [ dupd conjoin dup defined-by ] dip call
+    ] if ; inline
+
+: dfa ( node mark-quot iterate-quot -- assoc )
+    init-dfa
+    [ each-node ] dip
+    work-list get H{ { f f } } clone
+    [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline

unfinished/compiler/tree/propagation/branches/branches.factor

@@ -1,8 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel sequences assocs accessors namespaces
-math.intervals arrays classes.algebra
+math.intervals arrays classes.algebra locals
 compiler.tree
+compiler.tree.def-use
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.branches
@@ -11,60 +14,63 @@ IN: compiler.tree.propagation.branches
 GENERIC: child-constraints ( node -- seq )
 
 M: #if child-constraints
-    [
+    in-d>> first [ =t ] [ =f ] bi 2array ;
-        \ f class-not 0 `input class,
-        f 0 `input literal,
-    ] make-constraints ;
 
 M: #dispatch child-constraints
-    dup [
+    children>> length f <repetition> ;
-        children>> length [ 0 `input literal, ] each
-    ] make-constraints ;
 
-DEFER: (propagate)
+GENERIC: live-children ( #branch -- children )
+
+M: #if live-children
+    [ children>> ] [ in-d>> first value-info possible-boolean-values ] bi
+    [ t swap memq? [ first ] [ drop f ] if ]
+    [ f swap memq? [ second ] [ drop f ] if ]
+    2bi 2array ;
+
+M: #dispatch live-children
+    [ children>> ] [ in-d>> first value-info interval>> ] bi
+    '[ , interval-contains? [ drop f ] unless ] map-index ;
 
 : infer-children ( node -- assocs )
-    [ children>> ] [ child-constraints ] bi [
+    [ live-children ] [ child-constraints ] bi [
         [
-            value-classes [ clone ] change
+            over [
-            value-literals [ clone ] change
+                value-infos [ clone ] change
-            value-intervals [ clone ] change
                 constraints [ clone ] change
-            apply-constraint
+                assume
-            (propagate)
+                first>> (propagate)
+            ] [
+                2drop
+                value-infos off
+                constraints off
+            ] if
         ] H{ } make-assoc
     ] 2map ;
 
-: merge-classes ( inputs outputs results -- )
+: (merge-value-infos) ( inputs results -- infos )
-    '[
+    '[ , [ [ value-info ] bind ] 2map value-infos-union ] map ;
-        , null
-        [ [ value-class ] bind class-or ] 2reduce
-        _ set-value-class
-    ] 2each ;
 
-: merge-intervals ( inputs outputs results -- )
+: merge-value-infos ( results inputs outputs -- )
-    '[
+    [ swap (merge-value-infos) ] dip set-value-infos ;
-        , [ [ value-interval ] bind ] 2map
-        dup first [ interval-union ] reduce
-        _ set-value-interval
-    ] 2each ;
 
-: merge-literals ( inputs outputs results -- )
+: propagate-branch-phi ( results #phi -- )
-    '[
+    [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
-        , [ [ value-literal 2array ] bind ] 2map
+    [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
-        dup all-eq? [ first first2 ] [ drop f f ] if
+    2bi ;
-        _ swap [ set-value-literal ] [ 2drop ] if
-    ] 2each ;
 
-: merge-stuff ( inputs outputs results -- )
+:: branch-phi-constraints ( x #phi -- )
-    [ merge-classes ] [ merge-intervals ] [ merge-literals ] 3tri ;
+    #phi [ out-d>> ] [ phi-in-d>> ] bi [
+        first2 2dup and [ USE: prettyprint
+            [ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup  . assume ]
+            [ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup  . assume ]
+            3bi
+        ] [ 3drop ] if
+    ] 2each ;
 
 : merge-children ( results node -- )
-    successor>> dup #phi? [
+    [ successor>> propagate-branch-phi ]
-        [ [ phi-in-d>> ] [ out-d>> ] bi rot merge-stuff ]
+    [ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ]
-        [ [ phi-in-r>> ] [ out-r>> ] bi rot merge-stuff ]
+    bi ;
-        2bi
-    ] [ 2drop ] if ;
 
 M: #branch propagate-around
     [ infer-children ] [ merge-children ] [ annotate-node ] tri ;

unfinished/compiler/tree/propagation/constraints/constraints.factor

@@ -2,145 +2,123 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs math math.intervals kernel accessors
 sequences namespaces disjoint-sets classes classes.algebra
-combinators words compiler.tree ;
+combinators words
+compiler.tree compiler.tree.propagation.info
+compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.constraints
 
 ! A constraint is a statement about a value.
 
-! We need a notion of equality which doesn't recurse so cannot
+! Maps constraints to constraints ("A implies B")
-! infinite loop on circular data
-GENERIC: eql? ( obj1 obj2 -- ? )
-M: object eql? eq? ;
-M: number eql? number= ;
-
-! Maps constraints to constraints
 SYMBOL: constraints
 
-TUPLE: literal-constraint literal value ;
+GENERIC: assume ( constraint -- )
+GENERIC: satisfied? ( constraint -- ? )
+GENERIC: satisfiable? ( constraint -- ? )
 
-C: <literal-constraint> literal-constraint
+! Boolean constraints
+TUPLE: true-constraint value ;
 
-M: literal-constraint equal?
+: =t ( value -- constriant ) resolve-copy true-constraint boa ;
-    over literal-constraint? [
-        [ [ literal>> ] bi@ eql? ]
-        [ [ value>>   ] bi@ =    ]
-        2bi and
-    ] [ 2drop f ] if ;
 
-TUPLE: class-constraint class value ;
+M: true-constraint assume
+    [ constraints get at [ assume ] when* ]
+    [ \ f class-not <class-info> swap value>> refine-value-info ]
+    bi ;
 
-C: <class-constraint> class-constraint
+M: true-constraint satisfied?
+    value>> value-info class>> \ f class-not class<= ;
 
-TUPLE: interval-constraint interval value ;
+M: true-constraint satisfiable?
+    value>> value-info class>> \ f class-not classes-intersect? ;
 
-C: <interval-constraint> interval-constraint
+TUPLE: false-constraint value ;
 
-GENERIC: apply-constraint ( constraint -- )
+: =f ( value -- constriant ) resolve-copy false-constraint boa ;
-GENERIC: constraint-satisfied? ( constraint -- ? )
 
-: `input ( n -- value ) node get in-d>> nth ;
+M: false-constraint assume
-: `output ( n -- value ) node get out-d>> nth ;
+    [ constraints get at [ assume ] when* ]
-: class, ( class value -- ) <class-constraint> , ;
+    [ \ f <class-info> swap value>> refine-value-info ]
-: literal, ( literal value -- ) <literal-constraint> , ;
+    bi ;
-: interval, ( interval value -- ) <interval-constraint> , ;
 
-M: f apply-constraint drop ;
+M: false-constraint satisfied?
+    value>> value-info class>> \ f class<= ;
 
-: make-constraints ( node quot -- constraint )
+M: false-constraint satisfiable?
-    [ swap node set call ] { } make ; inline
+    value>> value-info class>> \ f classes-intersect? ;
 
-: set-constraints ( node quot -- )
+! Class constraints
-    make-constraints
+TUPLE: class-constraint value class ;
-    unclip [ 2array ] reduce
-    apply-constraint ; inline
 
-: assume ( constraint -- )
+: is-instance-of ( value class -- constraint )
-    constraints get at [ apply-constraint ] when* ;
+    [ resolve-copy ] dip class-constraint boa ;
 
-! Disjoint set of copy equivalence
+M: class-constraint assume
-SYMBOL: copies
+    [ class>> <class-info> ] [ value>> ] bi refine-value-info ;
 
-: is-copy-of ( val copy -- ) copies get equate ;
+! Interval constraints
+TUPLE: interval-constraint value interval ;
 
-: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+: is-in-interval ( value interval -- constraint )
+    [ resolve-copy ] dip interval-constraint boa ;
 
-: resolve-copy ( copy -- val ) copies get representative ;
+M: interval-constraint assume
+    [ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
 
-: introduce-value ( val -- ) copies get add-atom ;
+! Literal constraints
+TUPLE: literal-constraint value literal ;
 
-! Current value --> literal mapping
+: is-equal-to ( value literal -- constraint )
-SYMBOL: value-literals
+    [ resolve-copy ] dip literal-constraint boa ;
 
-! Current value --> interval mapping
+M: literal-constraint assume
-SYMBOL: value-intervals
+    [ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
 
-! Current value --> class mapping
+! Implication constraints
-SYMBOL: value-classes
+TUPLE: implication p q ;
 
-: value-interval ( value -- interval/f )
+C: --> implication
-    resolve-copy value-intervals get at ;
 
-: set-value-interval ( interval value -- )
+M: implication assume
-    resolve-copy value-intervals get set-at ;
+    [ q>> ] [ p>> ] bi
-
-: intersect-value-interval ( interval value -- )
-    resolve-copy value-intervals get [ interval-intersect ] change-at ;
-
-M: interval-constraint apply-constraint
-    [ interval>> ] [ value>> ] bi intersect-value-interval ;
-
-: set-class-interval ( class value -- )
-    over class? [
-        [ "interval" word-prop ] dip over
-        [ resolve-copy set-value-interval ] [ 2drop ] if
-    ] [ 2drop ] if ;
-
-: value-class ( value -- class )
-    resolve-copy value-classes get at null or ;
-
-: set-value-class ( class value -- )
-    resolve-copy over [
-        dup value-intervals get at [
-            2dup set-class-interval
-        ] unless
-        2dup <class-constraint> assume
-    ] when
-    value-classes get set-at ;
-
-: intersect-value-class ( class value -- )
-    resolve-copy value-classes get [ class-and ] change-at ;
-
-M: class-constraint apply-constraint
-    [ class>> ] [ value>> ] bi intersect-value-class ;
-
-: literal-interval ( value -- interval/f )
-    dup real? [ [a,a] ] [ drop f ] if ;
-
-: value-literal ( value -- obj ? )
-    resolve-copy value-literals get at* ;
-
-: set-value-literal ( literal value -- )
-    resolve-copy {
-        [ [ class ] dip set-value-class ]
-        [ [ literal-interval ] dip set-value-interval ]
-        [ <literal-constraint> assume ]
-        [ value-literals get set-at ]
-    } 2cleave ;
-
-M: literal-constraint apply-constraint
-    [ literal>> ] [ value>> ] bi set-value-literal ;
-
-M: literal-constraint constraint-satisfied?
-    dup value>> value-literal
-    [ swap literal>> eql? ] [ 2drop f ] if ;
-
-M: class-constraint constraint-satisfied?
-    [ value>> value-class ] [ class>> ] bi class<= ;
-
-M: pair apply-constraint
-    first2
     [ constraints get set-at ]
-    [ constraint-satisfied? [ apply-constraint ] [ drop ] if ] 2bi ;
+    [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 
-M: pair constraint-satisfied?
+M: implication satisfiable?
-    first constraint-satisfied? ;
+    [ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ;
+
+! Conjunction constraints
+TUPLE: conjunction p q ;
+
+C: /\ conjunction
+
+M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
+
+M: conjunction satisfiable?
+    [ p>> satisfiable? ] [ q>> satisfiable? ] bi and ;
+
+! Disjunction constraints
+TUPLE: disjunction p q ;
+
+C: \/ disjunction
+
+M: disjunction assume
+    {
+        { [ dup p>> satisfiable? not ] [ q>> assume ] }
+        { [ dup q>> satisfiable? not ] [ p>> assume ] }
+        [ drop ]
+    } cond ;
+
+M: disjunction satisfiable?
+    [ p>> satisfiable? ] [ q>> satisfiable? ] bi or ;
+
+! No-op
+M: f assume drop ;
+
+! Utilities
+: t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
+
+: f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
+
+: <conditional> ( true-constr false-constr boolean-value -- constraint )
+    tuck [ t--> ] [ f--> ] 2bi* /\ ;

unfinished/compiler/tree/propagation/info/info-tests.factor

@@ -0,0 +1,63 @@
+USING: accessors math math.intervals sequences classes.algebra
+math kernel tools.test compiler.tree.propagation.info ;
+IN: compiler.tree.propagation.info.tests
+
+[ f ] [ 0.0 -0.0 eql? ] unit-test
+
+[ t ] [
+    number <class-info>
+    sequence <class-info>
+    value-info-intersect
+    class>> integer class=
+] unit-test
+
+[ t t ] [
+    0 10 [a,b] <interval-info>
+    5 20 [a,b] <interval-info>
+    value-info-intersect
+    [ class>> real class= ]
+    [ interval>> 5 10 [a,b] = ]
+    bi
+] unit-test
+
+[ float 10.0 t ] [
+    10.0 <literal-info>
+    10.0 <literal-info>
+    value-info-intersect
+    [ class>> ] [ >literal< ] bi
+] unit-test
+
+[ null ] [
+    10 <literal-info>
+    10.0 <literal-info>
+    value-info-intersect
+    class>>
+] unit-test
+
+[ fixnum 10 t ] [
+    10 <literal-info>
+    10 <literal-info>
+    value-info-union
+    [ class>> ] [ >literal< ] bi
+] unit-test
+
+[ 3.0 t ] [
+    3 3 [a,b] <interval-info> float <class-info>
+    value-info-intersect >literal<
+] unit-test
+
+[ 3 t ] [
+    2 3 (a,b] <interval-info> fixnum <class-info>
+    value-info-intersect >literal<
+] unit-test
+
+[ T{ value-info f null empty-interval f f } ] [
+    fixnum -10 0 [a,b] <class/interval-info>
+    fixnum 19 29 [a,b] <class/interval-info>
+    value-info-intersect
+] unit-test
+
+[ 3 t ] [
+    3 <literal-info>
+    null <class-info> value-info-union >literal<
+] unit-test

unfinished/compiler/tree/propagation/info/info.factor

@@ -0,0 +1,146 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs classes classes.algebra kernel accessors math
+math.intervals namespaces sequences words combinators arrays
+compiler.tree.copy-equiv ;
+IN: compiler.tree.propagation.info
+
+SYMBOL: +interval+
+
+GENERIC: eql? ( obj1 obj2 -- ? )
+M: object eql? eq? ;
+M: fixnum eql? eq? ;
+M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
+M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
+M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
+M: complex eql? over complex? [ = ] [ 2drop f ] if ;
+
+! Value info represents a set of objects. Don't mutate value infos
+! you receive, always construct new ones. We don't declare the
+! slots read-only to allow cloning followed by writing.
+TUPLE: value-info
+{ class initial: null }
+{ interval initial: empty-interval }
+literal
+literal? ;
+
+: class-interval ( class -- interval )
+    dup real class<=
+    [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
+
+: interval>literal ( class interval -- literal literal? )
+    #! If interval has zero length and the class is sufficiently
+    #! precise, we can turn it into a literal
+    dup empty-interval eq? [
+        2drop f f
+    ] [
+        dup from>> first {
+            { [ over interval-length 0 > ] [ 3drop f f ] }
+            { [ pick bignum class<= ] [ 2nip >bignum t ] }
+            { [ pick integer class<= ] [ 2nip >fixnum t ] }
+            { [ pick float class<= ] [
+                2nip dup zero? [ drop f f ] [ >float t ] if
+            ] }
+            [ 3drop f f ]
+        } cond
+    ] if ;
+
+: <value-info> ( class interval literal literal? -- info )
+    [
+        2nip
+        [ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri
+        t
+    ] [
+        drop
+        2dup [ null class<= ] [ empty-interval eq? ] bi* or [
+            2drop null empty-interval f f
+        ] [
+            over integer class<= [ integral-closure ] when
+            2dup interval>literal
+        ] if
+    ] if
+    \ value-info boa ; foldable
+
+: <class/interval-info> ( class interval -- info )
+    f f <value-info> ; foldable
+
+: <class-info> ( class -- info )
+    dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
+    <class/interval-info> ; foldable
+
+: <interval-info> ( interval -- info )
+    real swap <class/interval-info> ; foldable
+
+: <literal-info> ( literal -- info )
+    f f rot t <value-info> ; foldable
+
+: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
+
+: intersect-literals ( info1 info2 -- literal literal? )
+    {
+        { [ dup literal?>> not ] [ drop >literal< ] }
+        { [ over literal?>> not ] [ nip >literal< ] }
+        { [ 2dup [ literal>> ] bi@ eql? not ] [ 2drop f f ] }
+        [ drop >literal< ]
+    } cond ;
+
+: (value-info-intersect) ( info1 info2 -- info )
+    [ [ class>> ] bi@ class-and ]
+    [ [ interval>> ] bi@ interval-intersect ]
+    [ intersect-literals ]
+    2tri <value-info> ;
+
+: value-info-intersect ( info1 info2 -- info )
+    {
+        { [ dup class>> null class<= ] [ nip ] }
+        { [ over class>> null class<= ] [ drop ] }
+        [ (value-info-intersect) ]
+    } cond ;
+
+: union-literals ( info1 info2 -- literal literal? )
+    2dup [ literal?>> ] both? [
+        [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
+    ] [ 2drop f f ] if ;
+
+: (value-info-union) ( info1 info2 -- info )
+    [ [ class>> ] bi@ class-or ]
+    [ [ interval>> ] bi@ interval-union ]
+    [ union-literals ]
+    2tri <value-info> ;
+
+: value-info-union ( info1 info2 -- info )
+    {
+        { [ dup class>> null class<= ] [ drop ] }
+        { [ over class>> null class<= ] [ nip ] }
+        [ (value-info-union) ]
+    } cond ;
+
+: value-infos-union ( infos -- info )
+    dup first [ value-info-union ] reduce ;
+
+! Current value --> info mapping
+SYMBOL: value-infos
+
+: value-info ( value -- info )
+    resolve-copy value-infos get at T{ value-info } or ;
+
+: set-value-info ( info value -- )
+    resolve-copy value-infos get set-at ;
+
+: refine-value-info ( info value -- )
+    resolve-copy value-infos get [ value-info-intersect ] change-at ;
+
+: value-literal ( value -- obj ? )
+    value-info >literal< ;
+
+: possible-boolean-values ( info -- values )
+    dup literal?>> [
+        literal>> 1array
+    ] [
+        class>> {
+            { [ dup null class<= ] [ { } ] }
+            { [ dup \ f class-not class<= ] [ { t } ] }
+            { [ dup \ f class<= ] [ { f } ] }
+            [ { t f } ]
+        } cond nip
+    ] if ;

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

@@ -0,0 +1,239 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel effects accessors math math.private math.libm
+math.partial-dispatch math.intervals math.parser math.order
+layouts words sequences sequences.private arrays assocs classes
+classes.algebra combinators generic.math splitting fry locals
+classes.tuple alien.accessors classes.tuple.private
+compiler.tree.propagation.info compiler.tree.propagation.nodes
+compiler.tree.propagation.constraints
+compiler.tree.comparisons ;
+IN: compiler.tree.propagation.known-words
+
+\ fixnum
+most-negative-fixnum most-positive-fixnum [a,b]
++interval+ set-word-prop
+
+\ array-capacity
+0 max-array-capacity [a,b]
++interval+ set-word-prop
+
+{ + - * / }
+[ { number number } "input-classes" set-word-prop ] each
+
+{ /f < > <= >= }
+[ { real real } "input-classes" set-word-prop ] each
+
+{ /i mod /mod }
+[ { rational rational } "input-classes" set-word-prop ] each
+
+{ bitand bitor bitxor bitnot shift }
+[ { integer integer } "input-classes" set-word-prop ] each
+
+\ bitnot { integer } "input-classes" set-word-prop
+
+{
+    fcosh
+    flog
+    fsinh
+    fexp
+    fasin
+    facosh
+    fasinh
+    ftanh
+    fatanh
+    facos
+    fpow
+    fatan
+    fatan2
+    fcos
+    ftan
+    fsin
+    fsqrt
+} [
+    dup stack-effect
+    [ in>> length real <repetition> "input-classes" set-word-prop ]
+    [ out>> length float <repetition> "default-output-classes" set-word-prop ]
+    2bi
+] each
+
+: ?change-interval ( info quot -- quot' )
+    over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
+
+{ bitnot fixnum-bitnot bignum-bitnot } [
+    [ [ interval-bitnot ] ?change-interval ] +outputs+ set-word-prop
+] each
+
+\ abs [ [ interval-abs ] ?change-interval ] +outputs+ set-word-prop
+
+: math-closure ( class -- newclass )
+    { fixnum bignum integer rational float real number object }
+    [ class<= ] with find nip ;
+
+: fits? ( interval class -- ? )
+    +interval+ word-prop interval-subset? ;
+
+: binary-op-class ( info1 info2 -- newclass )
+    [ class>> ] bi@
+    2dup [ null class<= ] either? [ 2drop null ] [
+        [ math-closure ] bi@ math-class-max
+    ] if ;
+
+: binary-op-interval ( info1 info2 quot -- newinterval )
+    [ [ interval>> ] bi@ ] dip call ; inline
+
+: won't-overflow? ( class interval -- ? )
+    [ fixnum class<= ] [ fixnum fits? ] bi* and ;
+
+: may-overflow ( class interval -- class' interval' )
+    over null class<= [
+        2dup won't-overflow?
+        [ [ integer math-class-max ] dip ] unless
+    ] unless ;
+
+: may-be-rational ( class interval -- class' interval' )
+    over null class<= [
+        [ rational math-class-max ] dip
+    ] unless ;
+
+: number-valued ( class interval -- class' interval' )
+    [ number math-class-min ] dip ;
+
+: integer-valued ( class interval -- class' interval' )
+    [ integer math-class-min ] dip ;
+
+: real-valued ( class interval -- class' interval' )
+    [ real math-class-min ] dip ;
+
+: float-valued ( class interval -- class' interval' )
+    over null class<= [
+        [ drop float ] dip
+    ] unless ;
+
+: binary-op ( word interval-quot post-proc-quot -- )
+    '[
+        [ binary-op-class ] [ , binary-op-interval ] 2bi
+        @
+        <class/interval-info>
+    ] +outputs+ set-word-prop ;
+
+\ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
+\ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
+
+\ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
+\ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
+
+\ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op
+\ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op
+
+\ / [ [ interval/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
+\ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
+\ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
+
+\ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
+\ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
+
+\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
+\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
+
+\ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
+\ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
+\ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
+
+:: (comparison-constraints) ( in1 in2 op -- constraint )
+    [let | i1 [ in1 value-info interval>> ]
+           i2 [ in2 value-info interval>> ] |
+       in1 i1 i2 op assumption is-in-interval
+       in2 i2 i1 op swap-comparison assumption is-in-interval
+       /\
+    ] ;
+
+: comparison-constraints ( in1 in2 out op -- constraint )
+    swap [
+        [ (comparison-constraints) ]
+        [ negate-comparison (comparison-constraints) ]
+        3bi
+    ] dip <conditional> ;
+
+: define-comparison-constraints ( word op -- )
+    '[ , comparison-constraints ] +constraints+ set-word-prop ;
+
+comparison-ops
+[ dup '[ , define-comparison-constraints ] each-derived-op ] each
+
+generic-comparison-ops [
+    dup specific-comparison
+    '[ , , define-comparison-constraints ] each-derived-op
+] each
+
+! Remove redundant comparisons
+: fold-comparison ( info1 info2 word -- info )
+    [ [ interval>> ] bi@ ] dip interval-comparison {
+        { incomparable [ object <class-info> ] }
+        { t [ t <literal-info> ] }
+        { f [ f <literal-info> ] }
+    } case ;
+
+comparison-ops [
+    [
+        dup '[ , fold-comparison ] +outputs+ set-word-prop
+    ] each-derived-op
+] each
+
+generic-comparison-ops [
+    dup specific-comparison
+    '[ , fold-comparison ] +outputs+ set-word-prop
+] each
+
+{
+    { >fixnum fixnum }
+    { >bignum bignum }
+    { >float float }
+} [
+    '[
+        ,
+        [ nip ] [
+            [ interval>> ] [ class-interval ] bi*
+            interval-intersect
+        ] 2bi
+        <class/interval-info>
+    ] +outputs+ set-word-prop
+] assoc-each
+
+{
+    alien-signed-1
+    alien-unsigned-1
+    alien-signed-2
+    alien-unsigned-2
+    alien-signed-4
+    alien-unsigned-4
+    alien-signed-8
+    alien-unsigned-8
+} [
+    dup name>> {
+        {
+            [ "alien-signed-" ?head ]
+            [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
+        }
+        {
+            [ "alien-unsigned-" ?head ]
+            [ string>number 8 * 2^ 1- 0 swap [a,b] ]
+        }
+    } cond
+    [ fixnum fits? fixnum bignum ? ] keep <class/interval-info>
+    [ 2nip ] curry +outputs+ set-word-prop
+] each
+
+{ <tuple> <tuple-boa> } [
+    [
+        literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if
+        [ clear ] dip
+    ] +outputs+ set-word-prop
+] each
+
+\ new [
+    literal>> dup tuple-class? [ drop tuple ] unless <class-info>
+] +outputs+ set-word-prop
+
+! the output of clone has the same type as the input
+{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each

unfinished/compiler/tree/propagation/nodes/nodes.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences accessors kernel
+compiler.tree.def-use
+compiler.tree.propagation.info ;
+IN: compiler.tree.propagation.nodes
+
+SYMBOL: +constraints+
+SYMBOL: +outputs+
+
+GENERIC: propagate-before ( node -- )
+
+GENERIC: propagate-after ( node -- )
+
+GENERIC: propagate-around ( node -- )
+
+: (propagate) ( node -- )
+    [
+        [ propagate-around ] [ successor>> ] bi
+        (propagate)
+    ] when* ;

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

@@ -0,0 +1,234 @@
+USING: kernel compiler.tree.builder compiler.tree
+compiler.tree.propagation compiler.tree.copy-equiv
+compiler.tree.def-use tools.test math math.order
+accessors sequences arrays kernel.private vectors
+alien.accessors alien.c-types sequences.private ;
+IN: compiler.tree.propagation.tests
+
+\ propagate must-infer
+\ propagate/node must-infer
+
+: final-info ( quot -- seq )
+    build-tree
+    compute-def-use
+    compute-copy-equiv
+    propagate
+    last-node node-input-infos ;
+
+: final-classes ( quot -- seq )
+    final-info [ class>> ] map ;
+
+: final-literals ( quot -- seq )
+    final-info [ literal>> ] map ;
+
+[ V{ } ] [ [ ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 1 >r r> ] final-classes ] unit-test
+
+[ V{ fixnum object } ] [ [ 1 swap ] final-classes ] unit-test
+
+[ V{ array } ] [ [ 10 f <array> ] final-classes ] unit-test
+
+[ V{ array } ] [ [ { array } declare ] final-classes ] unit-test
+
+[ V{ array } ] [ [ 10 f <array> swap [ ] [ ] if ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
+
+[ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
+
+[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
+
+[ V{ number } ] [ [ + ] final-classes ] unit-test
+
+[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
+
+[ V{ float } ] [ [ /f ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ /i ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
+
+[ V{ integer } ] [
+    [ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [
+        { fixnum } declare [ 255 bitand ] [ 65535 bitand ] bi +
+    ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ { fixnum } declare [ 255 bitand ] keep + ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ { fixnum } declare 615949 * ] final-classes
+] unit-test
+
+[ V{ null } ] [
+    [ { null null } declare + ] final-classes
+] unit-test
+
+[ V{ null } ] [
+    [ { null fixnum } declare + ] final-classes
+] unit-test
+
+[ V{ float } ] [
+    [ { float fixnum } declare + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 255 bitand >fixnum 3 bitor ] final-classes
+] unit-test
+
+[ V{ 0 } ] [
+    [ >fixnum 1 mod ] final-literals
+] unit-test
+
+[ V{ 69 } ] [
+    [ >fixnum swap [ 1 mod 69 + ] [ drop 69 ] if ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ >fixnum dup 10 > [ 1 - ] when ] final-classes
+] unit-test
+
+[ V{ integer } ] [ [ >fixnum 2 * ] final-classes ] unit-test
+
+[ V{ integer } ] [
+    [ >fixnum dup 10 < drop 2 * ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ >fixnum dup 10 < [ 2 * ] when ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ >fixnum dup 10 < [ 2 * ] [ 2 * ] if ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ >fixnum dup 10 < [ dup -10 > [ 2 * ] when ] when ] final-classes
+] unit-test
+
+[ V{ f } ] [
+    [ dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if ] final-literals
+] unit-test
+
+[ V{ 9 } ] [
+    [
+        123 bitand
+        dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
+    ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [
+        >fixnum
+        dup [ 10 < ] [ -10 > ] bi and not [ 2 * ] unless
+    ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare (clone) ] final-classes
+] unit-test
+
+[ V{ vector } ] [
+    [ vector new ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [
+        [ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth
+        >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
+        255 min 0 max
+    ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 > [ 2 * ] when ] final-classes
+] unit-test
+
+[ V{ f } ] [
+    [ [ 0.0 ] [ -0.0 ] if ] final-literals
+] unit-test
+
+[ V{ 1.5 } ] [
+    [ /f 1.5 min 1.5 max ] final-literals
+] unit-test
+
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
+[ V{ f } ] [
+    [
+        /f
+        dup 0.0 <= [ dup 0.0 >= [ drop 0.0 ] unless ] [ drop 0.0 ] if
+    ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 > [ 100 * ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 > [ drop "foo" ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare 3 3 - + ] final-classes
+] unit-test
+
+[ V{ t } ] [
+    [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
+] unit-test
+
+[ V{ "d" } ] [
+    [
+        3 {
+            [ "a" ]
+            [ "b" ]
+            [ "c" ]
+            [ "d" ]
+            [ "e" ]
+            [ "f" ]
+            [ "g" ]
+            [ "h" ]
+        } dispatch
+    ] final-literals
+] unit-test
+
+[ V{ "hi" } ] [
+    [ [ "hi" ] [ 123 3 throw ] if ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
+] unit-test
+
+[ V{ -1 } ] [
+    [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ [ 1 >r ] [ 2 >r ] if r> 3 + ] final-classes
+] unit-test
+
+[ V{ 2 } ] [
+    [ [ 1 ] [ 1 ] if 1 + ] final-literals
+] unit-test

unfinished/compiler/tree/propagation/propagation.factor

@@ -3,35 +3,24 @@
 USING: accessors kernel sequences namespaces hashtables
 compiler.tree
 compiler.tree.def-use
-compiler.tree.propagation.constraints
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
 compiler.tree.propagation.branches
-compiler.tree.propagation.recursive ;
+compiler.tree.propagation.recursive
+compiler.tree.propagation.constraints
+compiler.tree.propagation.known-words ;
 IN: compiler.tree.propagation
 
-: (propagate) ( node -- )
+: propagate-with ( node infos -- )
-    [
-        [ node-defs-values [ introduce-value ] each ]
-        [ propagate-around ]
-        [ successor>> ]
-        tri
-        (propagate)
-    ] when* ;
-
-: propagate-with ( node classes literals intervals -- )
     [
         H{ } clone constraints set
-        >hashtable value-intervals set
+        >hashtable value-infos set
-        >hashtable value-literals set
-        >hashtable value-classes set
         (propagate)
     ] with-scope ;
 
 : propagate ( node -- node )
-    dup f f f propagate-with ;
+    dup f propagate-with ;
 
 : propagate/node ( node existing -- )
-    #! Infer classes, using the existing node's class info as a
+    info>> propagate-with ;
-    #! starting point.
-    [ classes>> ] [ literals>> ] [ intervals>> ] tri
-    propagate-with ;

unfinished/compiler/tree/propagation/recursive/recursive.factor

@@ -1,72 +1,36 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.tree compiler.tree.propagation.simple
+USING: kernel sequences accessors
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
+compiler.tree.propagation.simple
 compiler.tree.propagation.branches ;
 IN: compiler.tree.propagation.recursive
 
-! M: #recursive child-constraints
+! What if we reach a fixed point for the phi but not for the
-!     drop { f } ;
+! #call-label output?
-! 
+
-! M: #recursive propagate-around
+! We need to compute scalar evolution so that sccp doesn't
-!     [ infer-children ] [ merge-children ] [ annotate-node ] tri ;
+! evaluate loops
-! 
+
-! : classes= ( inferred current -- ? )
+: (merge-value-infos) ( inputs -- infos )
-!     2dup min-length '[ , tail* ] bi@ sequence= ;
+    [ [ value-info ] map value-infos-union ] map ;
-! 
+
-! SYMBOL: fixed-point?
+: merge-value-infos ( inputs outputs -- fixed-point? )
-! 
+    [ (merge-value-infos) ] dip
-! SYMBOL: nested-labels
+    [ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ;
-! 
+
-! : annotate-entry ( nodes #label -- )
+: propagate-recursive-phi ( #phi -- fixed-point? )
-!     [ (merge-classes) ] dip node-child
+    [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
-!     2dup node-output-classes classes=
+    [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
-!     [ 2drop ] [ set-classes fixed-point? off ] if ;
+    bi and ;
-! 
+
-! : init-recursive-calls ( #label -- )
+M: #recursive propagate-around ( #recursive -- )
-!     #! We set recursive calls to output the empty type, then
+    dup
-!     #! repeat inference until a fixed point is reached.
+    node-child
-!     #! Hopefully, our type functions are monotonic so this
+    [ first>> (propagate) ] [ propagate-recursive-phi ] bi
-!     #! will always converge.
+    [ drop ] [ propagate-around ] if ;
-!     returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
+
-! 
+M: #call-recursive propagate-before ( #call-label -- )
-! M: #label propagate-before ( #label -- )
+    [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;
-!     [ init-recursive-calls ]
-!     [ [ 1array ] keep annotate-entry ] bi ;
-! 
-! : infer-label-loop ( #label -- )
-!     fixed-point? on
-!     dup node-child (propagate)
-!     dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
-!     fixed-point? get [ drop ] [ infer-label-loop ] if ;
-! 
-! M: #label propagate-around ( #label -- )
-!     #! Now merge the types at every recursion point with the
-!     #! entry types.
-!     [
-!         {
-!             [ nested-labels get push ]
-!             [ annotate-node ]
-!             [ propagate-before ]
-!             [ infer-label-loop ]
-!             [ drop nested-labels get pop* ]
-!         } cleave
-!     ] with-scope ;
-! 
-! : find-label ( param -- #label )
-!     word>> nested-labels get [ word>> eq? ] with find nip ;
-! 
-! M: #call-recursive propagate-before ( #call-label -- )
-!     [ label>> returns>> (merge-classes) ] [ out-d>> ] bi
-!     [ set-value-class ] 2each ;
-! 
-! M: #return propagate-around
-!     nested-labels get length 0 > [
-!         dup word>> nested-labels get peek word>> eq? [
-!             [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
-!             classes= not [
-!                 fixed-point? off
-!                 [ in-d>> value-classes get valid-keys ] keep
-!                 set-node-classes
-!             ] [ drop ] if
-!         ] [ call-next-method ] if
-!     ] [ call-next-method ] if ;

unfinished/compiler/tree/propagation/simple/simple.factor

@@ -1,112 +1,105 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors kernel sequences assocs words namespaces
-combinators classes.algebra compiler.tree
+classes.algebra combinators classes continuations
+compiler.tree
+compiler.tree.def-use
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.simple
 
-GENERIC: propagate-before ( node -- )
-
 M: #introduce propagate-before
-    values>> [ object swap set-value-class ] each ;
+    object <class-info> swap values>> [ set-value-info ] with each ;
 
 M: #push propagate-before
-    [ literal>> ] [ out-d>> first ] bi set-value-literal ;
+    [ literal>> value>> <literal-info> ] [ out-d>> first ] bi
+    set-value-info ;
+
+: refine-value-infos ( classes values -- )
+    [ refine-value-info ] 2each ;
+
+: class-infos ( classes -- infos )
+    [ <class-info> ] map ;
+
+: set-value-infos ( infos values -- )
+    [ set-value-info ] 2each ;
 
 M: #declare propagate-before
-    [ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
+    declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
-    [ [ declaration>> ] [ out-d>> ] bi [ intersect-value-class ] 2each ]
-    bi ;
 
-M: #shuffle propagate-before
+: predicate-constraints ( value class boolean-value -- constraint )
-    [ out-r>> dup ] [ mapping>> ] bi '[ , at ] map are-copies-of ;
+    [ [ is-instance-of ] dip t--> ]
+    [ [ class-not is-instance-of ] dip f--> ]
+    3bi /\ ;
 
-M: #>r propagate-before
+: custom-constraints ( #call quot -- )
-    [ in-d>> ] [ out-r>> ] bi are-copies-of ;
+    [ [ in-d>> ] [ out-d>> ] bi append ] dip
-
+    with-datastack first assume ;
-M: #r> propagate-before
-    [ in-r>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #copy propagate-before
-    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
-
-: intersect-classes ( classes values -- )
-    [ intersect-value-class ] 2each ;
-
-: intersect-intervals ( intervals values -- )
-    [ intersect-value-interval ] 2each ;
-
-: predicate-constraints ( class #call -- )
-    [
-        ! If word outputs true, input is an instance of class
-        [
-            0 `input class,
-            \ f class-not 0 `output class,
-        ] set-constraints
-    ] [
-        ! If word outputs false, input is not an instance of class
-        [
-            class-not 0 `input class,
-            \ f 0 `output class,
-        ] set-constraints
-    ] 2bi ;
 
 : compute-constraints ( #call -- )
-    dup word>> "constraints" word-prop [
+    dup word>> +constraints+ word-prop [ custom-constraints ] [
-        call
+        dup word>> predicate? [
-    ] [
+            [ in-d>> first ]
-        dup word>> "predicating" word-prop dup
+            [ word>> "predicating" word-prop ]
-        [ swap predicate-constraints ] [ 2drop ] if
+            [ out-d>> first ]
+            tri predicate-constraints assume
+        ] [ drop ] if
     ] if* ;
 
-: compute-output-classes ( node word -- classes intervals )
+: call-outputs-quot ( node -- infos )
-    dup word>> "output-classes" word-prop
+    [ in-d>> [ value-info ] map ]
-    dup [ call ] [ 2drop f f ] if ;
+    [ word>> +outputs+ word-prop ]
+    bi with-datastack ;
 
-: output-classes ( node -- classes intervals )
+: foldable-call? ( #call -- ? )
-    dup compute-output-classes [
+    dup word>> "foldable" word-prop [
-        [ ] [ word>> "default-output-classes" word-prop ] ?if
+        in-d>> [ value-info literal?>> ] all?
-    ] dip ;
+    ] [
+        drop f
+    ] if ;
 
-: intersect-values ( classes intervals values -- )
+: fold-call ( #call -- infos )
-    tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
+    [ in-d>> [ value-info literal>> ] map ]
+    [ word>> [ execute ] curry ]
+    bi with-datastack
+    [ <literal-info> ] map ;
+
+: default-output-value-infos ( node -- infos )
+    dup word>> "default-output-classes" word-prop [
+        class-infos
+    ] [
+        out-d>> length object <class-info> <repetition>
+    ] ?if ;
+
+: output-value-infos ( node -- infos )
+    {
+        { [ dup foldable-call? ] [ fold-call ] }
+        { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
+        [ default-output-value-infos ]
+    } cond ;
 
 M: #call propagate-before
+    [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ]
     [ compute-constraints ]
-    [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
+    bi ;
 
 M: node propagate-before drop ;
 
-GENERIC: propagate-after ( node -- )
-
-: input-classes ( #call -- classes )
-    word>> "input-classes" word-prop ;
-
 M: #call propagate-after
-    [ input-classes ] [ in-d>> ] bi intersect-classes ;
+    dup word>> "input-classes" word-prop dup [
+        class-infos swap in-d>> refine-value-infos
+    ] [
+        2drop
+    ] if ;
 
 M: node propagate-after drop ;
 
-GENERIC: propagate-around ( node -- )
-
-: valid-keys ( seq assoc -- newassoc )
-    '[ dup resolve-copy , at ] H{ } map>assoc
-    [ nip ] assoc-filter
-    f assoc-like ;
-
 : annotate-node ( node -- )
-    #! Annotate the node with the currently-inferred set of
+    dup
-    #! value classes.
+    [ node-defs-values ] [ node-uses-values ] bi append
-    dup node-values {
+    [ dup value-info ] H{ } map>assoc
-        [ value-intervals get valid-keys >>intervals ]
+    >>info drop ;
-        [ value-classes   get valid-keys >>classes   ]
-        [ value-literals  get valid-keys >>literals  ]
-        [ 2drop ]
-    } cleave ;
 
-M: object propagate-around
+M: node propagate-around
-    {
+    [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
-        [ propagate-before ]
-        [ annotate-node ]
-        [ propagate-after ]
-    } cleave ;

unfinished/compiler/tree/tree.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs kernel math namespaces parser
 sequences words vectors math.intervals effects classes
-accessors combinators stack-checker.state ;
+accessors combinators stack-checker.state stack-checker.visitor ;
 IN: compiler.tree
 
 ! High-level tree SSA form.
@@ -16,22 +16,13 @@ IN: compiler.tree
 ! case of a #phi node, the sequence of sequences in the phi-in-r
 ! and phi-in-d slots.
 ! 3) A value is never used in the same node where it is defined.
-
 TUPLE: node < identity-tuple
-in-d out-d in-r out-r
+in-d out-d in-r out-r info
-classes literals intervals
+successor children ;
-history successor children ;
 
 M: node hashcode* drop node hashcode* ;
 
-: node-shuffle ( node -- shuffle )
+: node-child ( node -- child ) children>> first ;
-    [ in-d>> ] [ out-d>> ] bi <effect> ;
-
-: node-values ( node -- values )
-    { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
-    4array concat ;
-
-: node-child ( node -- child ) node-children first ;
 
 : last-node ( node -- last )
     dup successor>> [ last-node ] [ ] ?if ;
@@ -44,36 +35,21 @@ M: node hashcode* drop node hashcode* ;
         2drop f
     ] if ;
 
-: node-literal? ( node value -- ? )
+: node-value-info ( node value -- info )
-    swap literals>> key? ;
+    swap info>> at ;
 
-: node-literal ( node value -- obj )
+: node-input-infos ( node -- seq )
-    swap literals>> at ;
+    dup in-d>> [ node-value-info ] with map ;
 
-: node-interval ( node value -- interval )
+: node-output-infos ( node -- seq )
-    swap intervals>> at ;
+    dup out-d>> [ node-value-info ] with map ;
-
-: node-class ( node value -- class )
-    swap classes>> at ;
-
-: node-input-classes ( node -- seq )
-    dup in-d>> [ node-class ] with map ;
-
-: node-output-classes ( node -- seq )
-    dup out-d>> [ node-class ] with map ;
-
-: node-input-intervals ( node -- seq )
-    dup in-d>> [ node-interval ] with map ;
-
-: node-class-first ( node -- class )
-    dup in-d>> first node-class ;
 
 TUPLE: #introduce < node values ;
 
 : #introduce ( values -- node )
     \ #introduce new swap >>values ;
 
-TUPLE: #call < node word ;
+TUPLE: #call < node word history ;
 
 : #call ( inputs outputs word -- node )
     \ #call new
@@ -153,11 +129,9 @@ TUPLE: #phi < node phi-in-d phi-in-r ;
 
 TUPLE: #declare < node declaration ;
 
-: #declare ( inputs outputs declaration -- node )
+: #declare ( declaration -- node )
     \ #declare new
-        swap >>declaration
+        swap >>declaration ;
-        swap >>out-d
-        swap >>in-d ;
 
 TUPLE: #return < node label ;
 
@@ -188,3 +162,30 @@ DEFER: #tail?
 PREDICATE: #tail-phi < #phi successor>> #tail? ;
 
 UNION: #tail POSTPONE: f #return #tail-phi #terminate ;
+
+TUPLE: node-list first last ;
+
+: node, ( node -- )
+    stack-visitor get swap
+    over last>>
+    [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
+    [ [ >>first ] [ >>last ] bi drop ]
+    if ;
+
+M: node-list child-visitor node-list new ;
+M: node-list #introduce, #introduce node, ;
+M: node-list #call, #call node, ;
+M: node-list #call-recursive, #call-recursive node, ;
+M: node-list #push, #push node, ;
+M: node-list #shuffle, #shuffle node, ;
+M: node-list #drop, #drop node, ;
+M: node-list #>r, #>r node, ;
+M: node-list #r>, #r> node, ;
+M: node-list #return, #return node, ;
+M: node-list #terminate, #terminate node, ;
+M: node-list #if, #if node, ;
+M: node-list #dispatch, #dispatch node, ;
+M: node-list #phi, #phi node, ;
+M: node-list #declare, #declare node, ;
+M: node-list #recursive, #recursive node, ;
+M: node-list #copy, #copy node, ;

unfinished/compiler/tree/untupling/untupling-tests.factor

@@ -0,0 +1,50 @@
+IN: compiler.tree.untupling.tests
+USING: assocs math kernel quotations.private slots.private
+compiler.tree.builder
+compiler.tree.def-use
+compiler.tree.copy-equiv
+compiler.tree.untupling
+tools.test ;
+
+: check-untupling ( quot -- sizes )
+    build-tree
+    compute-copy-equiv
+    compute-def-use
+    compute-untupling
+    values ;
+
+[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
+
+[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test
+
+[ { 2 2 } ] [
+    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling
+] unit-test
+
+[ { } ] [
+    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling
+] unit-test
+
+[ { 2 2 2 } ] [
+    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling
+] unit-test
+
+[ { 2 2 } ] [
+    [ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling
+] unit-test
+
+[ { } ] [
+    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling
+] unit-test

unfinished/compiler/tree/untupling/untupling.factor

@@ -0,0 +1,59 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors slots.private kernel namespaces disjoint-sets
+math sequences assocs classes.tuple.private combinators fry sets
+compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
+compiler.tree.dfa compiler.tree.dfa.backward ;
+IN: compiler.tree.untupling
+
+SYMBOL: escaping-values
+
+: mark-escaping-values ( node -- )
+    in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
+
+SYMBOL: untupling-candidates
+
+: untupling-candidate ( #call class -- )
+    #! 1- for delegate
+    size>> 1- swap out-d>> first resolve-copy
+    untupling-candidates get set-at ;
+
+GENERIC: compute-untupling* ( node -- )
+
+M: #call compute-untupling*
+    dup word>> {
+        { \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
+        { \ curry [ \ curry tuple-layout untupling-candidate ] }
+        { \ compose [ \ compose tuple-layout untupling-candidate ] }
+        { \ slot [ drop ] }
+        [ drop mark-escaping-values ]
+    } case ;
+
+M: #return compute-untupling*
+    dup label>> [ drop ] [ mark-escaping-values ] if ;
+
+M: node compute-untupling* drop ;
+
+GENERIC: check-consistency* ( node -- )
+
+: check-value-consistency ( out-value in-values -- )
+    swap escaping-values get key? [
+        escaping-values get '[ , conjoin ] each
+    ] [
+        untupling-candidates get 2dup '[ , at ] map all-equal?
+        [ 2drop ] [ '[ , delete-at ] each ] if
+    ] if ;
+
+M: #phi check-consistency*
+    [ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
+    [ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
+    bi ;
+
+M: node check-consistency* drop ;
+
+: compute-untupling ( node -- assoc )
+    H{ } clone escaping-values set
+    H{ } clone untupling-candidates set
+    [ [ compute-untupling* ] each-node ]
+    [ [ check-consistency* ] each-node ] bi
+    untupling-candidates get escaping-values get assoc-diff ;

unfinished/math/partial-dispatch/partial-dispatch-tests.factor

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

unfinished/math/partial-dispatch/partial-dispatch.factor

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

unfinished/stack-checker/backend/backend.factor

@@ -11,6 +11,8 @@ IN: stack-checker.backend
 ! Word properties we use
 SYMBOL: +inferred-effect+
 SYMBOL: +cannot-infer+
+SYMBOL: +special+
+SYMBOL: +shuffle+
 SYMBOL: +infer+
 
 SYMBOL: visited
@@ -174,7 +176,7 @@ M: object apply-object push-literal ;
         [
             init-inference
             init-known-values
-            dataflow-visitor off
+            stack-visitor off
             dependencies off
             [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
             [ finish-word current-effect ]
@@ -191,32 +193,19 @@ M: object apply-object push-literal ;
 : call-recursive-word ( word -- )
     dup required-stack-effect apply-word/effect ;
 
-: custom-infer ( word -- )
-    [ +inlined+ depends-on ] [ +infer+ word-prop call ] bi ;
-
 : cached-infer ( word -- )
     dup +inferred-effect+ word-prop apply-word/effect ;
 
-: non-inline-word ( word -- )
-    dup +called+ depends-on
-    {
-        { [ dup recursive-label ] [ call-recursive-word ] }
-        { [ dup +infer+ word-prop ] [ custom-infer ] }
-        { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
-        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
-        [ dup infer-word apply-word/effect ]
-    } cond ;
-
 : with-infer ( quot -- effect visitor )
     [
         [
             V{ } clone recorded set
             init-inference
             init-known-values
-            dataflow-visitor off
+            stack-visitor off
             call
             end-infer
             current-effect
-            dataflow-visitor get
+            stack-visitor get
         ] [ ] [ undo-infer ] cleanup
-    ] with-scope ;
+    ] with-scope ; inline

unfinished/stack-checker/branches/branches.factor

@@ -12,7 +12,7 @@ IN: stack-checker.branches
 : phi-inputs ( seq -- newseq )
     dup empty? [
         dup [ length ] map supremum
-        '[ , f pad-left ] map
+        '[ , f pad-left ] map flip
     ] unless ;
 
 : unify-values ( values -- phi-out )
@@ -20,7 +20,7 @@ IN: stack-checker.branches
     [ nip first make-known ] [ 2drop <value> ] if ;
 
 : phi-outputs ( phi-in -- stack )
-    flip [ unify-values ] map ;
+    [ unify-values ] map ;
 
 SYMBOL: quotations
 
@@ -47,7 +47,7 @@ SYMBOL: quotations
 : retainstack-phi ( seq -- phi-in phi-out )
     [ length 0 <repetition> ] [ meta-r active-variable ] bi
     unify-branches
-    [ drop ] [ ] [ dup meta-r set ] tri* ;
+    [ drop ] [ ] [ dup >vector meta-r set ] tri* ;
 
 : compute-phi-function ( seq -- )
     [ quotation active-variable sift quotations set ]
@@ -65,10 +65,21 @@ SYMBOL: quotations
 : infer-branches ( branches -- input children data )
     [ pop-d ] dip
     [ infer-branch ] map
-    [ dataflow-visitor branch-variable ] keep ;
+    [ stack-visitor branch-variable ] keep ;
 
-: infer-if ( branches -- )
+: (infer-if) ( branches -- )
     infer-branches [ first2 #if, ] dip compute-phi-function ;
 
-: infer-dispatch ( branches -- )
+: infer-if ( -- )
+    2 consume-d
+    dup [ known [ curry? ] [ composed? ] bi or ] contains? [
+        output-d
+        [ rot [ drop call ] [ nip call ] if ]
+        recursive-state get infer-quot
+    ] [
+        [ #drop, ] [ [ literal ] map (infer-if) ] bi
+    ] if ;
+
+: infer-dispatch ( -- )
+    pop-literal nip [ <literal> ] map
     infer-branches [ #dispatch, ] dip compute-phi-function ;

unfinished/stack-checker/inlining/inlining.factor

@@ -6,7 +6,8 @@ stack-checker.state
 stack-checker.visitor
 stack-checker.backend
 stack-checker.branches
-stack-checker.errors ;
+stack-checker.errors
+stack-checker.known-words ;
 IN: stack-checker.inlining
 
 ! Code to handle inline words. Much of the complexity stems from
@@ -80,7 +81,7 @@ SYMBOL: phi-out
 
         dup recursive-word-inputs
         meta-d get
-        dataflow-visitor get
+        stack-visitor get
     ] with-scope ;
 
 : inline-recursive-word ( word -- )
@@ -104,7 +105,7 @@ SYMBOL: phi-out
     [
         [ call-site-stack ] dip
         [ check-call-site-stack ]
-        [ phi-in>> push ]
+        [ phi-in>> swap [ suffix ] 2change-each ]
         2bi
     ] 2bi ;
 

unfinished/stack-checker/known-words/known-words.factor

@@ -2,26 +2,25 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors alien alien.accessors arrays byte-arrays
 classes sequences.private continuations.private effects generic
-hashtables hashtables.private io io.backend io.files io.files.private
+hashtables hashtables.private io io.backend io.files
-io.streams.c kernel kernel.private math math.private memory
+io.files.private io.streams.c kernel kernel.private math
-namespaces namespaces.private parser prettyprint quotations
+math.private memory namespaces namespaces.private parser
-quotations.private sbufs sbufs.private sequences
+prettyprint quotations quotations.private sbufs sbufs.private
-sequences.private slots.private strings strings.private system
+sequences sequences.private slots.private strings
-threads.private classes.tuple classes.tuple.private vectors
+strings.private system threads.private classes.tuple
-vectors.private words words.private assocs summary
+classes.tuple.private vectors vectors.private words definitions
-compiler.units system.private
+words.private assocs summary compiler.units system.private
-stack-checker.state stack-checker.backend stack-checker.branches
+combinators locals.backend stack-checker.state
-stack-checker.errors stack-checker.visitor ;
+stack-checker.backend stack-checker.branches
+stack-checker.errors stack-checker.transforms
+stack-checker.visitor ;
 IN: stack-checker.known-words
 
-: infer-shuffle ( shuffle -- )
+: infer-primitive ( word -- )
-    [ in>> length consume-d ] keep ! inputs shuffle
+    dup
-    [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies
+    [ "input-classes" word-prop ]
-    [ nip ] [ swap zip ] 2bi ! inputs copies mapping
+    [ "default-output-classes" word-prop ] bi <effect>
-    #shuffle, ;
+    apply-word/effect ;
-
-: define-shuffle ( word shuffle -- )
-    '[ , infer-shuffle ] +infer+ set-word-prop ;
 
 {
     { drop  (( x     --             )) }
@@ -40,19 +39,22 @@ IN: stack-checker.known-words
     { over  (( x y   -- x y x       )) }
     { pick  (( x y z -- x y z x     )) }
     { swap  (( x y   -- y x         )) }
-} [ define-shuffle ] assoc-each
+} [ +shuffle+ set-word-prop ] assoc-each
 
-\ >r [ 1 infer->r ] +infer+ set-word-prop
+: infer-shuffle ( shuffle -- )
-\ r> [ 1 infer-r> ] +infer+ set-word-prop
+    [ in>> length consume-d ] keep ! inputs shuffle
+    [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies
+    [ nip ] [ swap zip ] 2bi ! inputs copies mapping
+    #shuffle, ;
 
+: infer-shuffle-word ( word -- )
+    +shuffle+ word-prop infer-shuffle ;
 
-\ declare [
+: infer-declare ( -- )
     pop-literal nip
-    [ length consume-d dup copy-values ] keep
+    [ length ensure-d ] keep zip
-    #declare,
+    #declare, ;
-] +infer+ set-word-prop
 
-! Primitive combinators
 GENERIC: infer-call* ( value known -- )
 
 : infer-call ( value -- ) dup known infer-call* ;
@@ -73,495 +75,524 @@ M: composed infer-call*
     [ quot2>> known pop-d [ set-known ] keep ]
     [ quot1>> known pop-d [ set-known ] keep ] bi
     push-d push-d
-    [ slip call ] recursive-state get infer-quot ;
+    1 infer->r pop-d infer-call
+    terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
 
 M: object infer-call*
     \ literal-expected inference-warning ;
 
-\ call [ pop-d infer-call ] +infer+ set-word-prop
+: infer-curry ( -- )
-
-\ call t "no-compile" set-word-prop
-
-\ curry [
     2 consume-d
     dup first2 <curried> make-known
     [ push-d ] [ 1array ] bi
-    \ curry #call,
+    \ curry #call, ;
-] +infer+ set-word-prop
 
-\ compose [
+: infer-compose ( -- )
     2 consume-d
     dup first2 <composed> make-known
     [ push-d ] [ 1array ] bi
-    \ compose #call,
+    \ compose #call, ;
-] +infer+ set-word-prop
 
-\ execute [
+: infer-execute ( -- )
     pop-literal nip
     dup word? [
         apply-object
     ] [
         drop
         "execute must be given a word" time-bomb
-    ] if
+    ] if ;
-] +infer+ set-word-prop
 
-\ execute t "no-compile" set-word-prop
+: infer-<tuple-boa> ( -- )
-
-\ if [
-    2 consume-d
-    dup [ known [ curry? ] [ composed? ] bi or ] contains? [
-        output-d
-        [ rot [ drop call ] [ nip call ] if ]
-        recursive-state get infer-quot
-    ] [
-        [ #drop, ] [ [ literal ] map infer-if ] bi
-    ] if
-] +infer+ set-word-prop
-
-\ dispatch [
-    pop-literal nip [ <literal> ] map infer-dispatch
-] +infer+ set-word-prop
-
-\ dispatch t "no-compile" set-word-prop
-
-! Variadic tuple constructor
-\ <tuple-boa> [
     \ <tuple-boa>
     peek-d literal value>> size>> { tuple } <effect>
-    apply-word/effect
+    apply-word/effect ;
-] +infer+ set-word-prop
 
-! Non-standard control flow
+: infer-(throw) ( -- )
-\ (throw) [
     \ (throw)
     peek-d literal value>> 2 + f <effect> t >>terminated?
-    apply-word/effect
+    apply-word/effect ;
-] +infer+ set-word-prop
 
-:  set-primitive-effect ( word effect -- )
+: infer-exit ( -- )
-    [ in>> "input-classes" set-word-prop ]
+    \ exit
-    [ out>> "default-output-classes" set-word-prop ]
+    { integer } { } t >>terminated? <effect>
-    [ dupd '[ , , apply-word/effect ] +infer+ set-word-prop ]
+    apply-word/effect ;
-    2tri ;
+
+: infer-load-locals ( -- )
+    pop-literal nip
+    [ dup reverse <effect> infer-shuffle ]
+    [ infer->r ]
+    bi ;
+
+: infer-get-local ( -- )
+    pop-literal nip
+    [ infer-r> ]
+    [ dup 0 prefix <effect> infer-shuffle ]
+    [ infer->r ]
+    tri ;
+
+: infer-drop-locals ( -- )
+    pop-literal nip
+    [ infer-r> ]
+    [ { } <effect> infer-shuffle ] bi ;
+
+: infer-special ( word -- )
+    {
+        { \ >r [ 1 infer->r ] }
+        { \ r> [ 1 infer-r> ] }
+        { \ declare [ infer-declare ] }
+        { \ call [ pop-d infer-call ] }
+        { \ curry [ infer-curry ] }
+        { \ compose [ infer-compose ] }
+        { \ execute [ infer-execute ] }
+        { \ if [ infer-if ] }
+        { \ dispatch [ infer-dispatch ] }
+        { \ <tuple-boa> [ infer-<tuple-boa> ] }
+        { \ (throw) [ infer-(throw) ] }
+        { \ exit [ infer-exit ] }
+        { \ load-locals [ infer-load-locals ] }
+        { \ get-local [ infer-get-local ] }
+        { \ drop-locals [ infer-drop-locals ] }
+        { \ do-primitive [ \ do-primitive cannot-infer-effect ] }
+    } case ;
+
+{
+    >r r> declare call curry compose
+    execute if dispatch <tuple-boa>
+    (throw) load-locals get-local drop-locals
+    do-primitive
+} [ t +special+ set-word-prop ] each
+
+{ call execute dispatch load-locals get-local drop-locals }
+[ t "no-compile" set-word-prop ] each
+
+: non-inline-word ( word -- )
+    dup +called+ depends-on
+    {
+        { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
+        { [ dup +special+ word-prop ] [ infer-special ] }
+        { [ dup primitive? ] [ infer-primitive ] }
+        { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
+        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
+        { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
+        { [ dup "macro" word-prop ] [ apply-macro ] }
+        { [ dup recursive-label ] [ call-recursive-word ] }
+        [ dup infer-word apply-word/effect ]
+    } cond ;
+
+: define-primitive ( word inputs outputs -- )
+    [ drop "input-classes" set-word-prop ]
+    [ nip "default-output-classes" set-word-prop ]
+    3bi ;
 
 ! Stack effects for all primitives
-\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum< { fixnum fixnum } { object } define-primitive
 \ fixnum< make-foldable
 
-\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum<= { fixnum fixnum } { object } define-primitive
 \ fixnum<= make-foldable
 
-\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum> { fixnum fixnum } { object } define-primitive
 \ fixnum> make-foldable
 
-\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum>= { fixnum fixnum } { object } define-primitive
 \ fixnum>= make-foldable
 
-\ eq? { object object } { object } <effect> set-primitive-effect
+\ eq? { object object } { object } define-primitive
 \ eq? make-foldable
 
-\ rehash-string { string } { } <effect> set-primitive-effect
+\ bignum>fixnum { bignum } { fixnum } define-primitive
-
-\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
 \ bignum>fixnum make-foldable
 
-\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
+\ float>fixnum { float } { fixnum } define-primitive
 \ bignum>fixnum make-foldable
 
-\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
+\ fixnum>bignum { fixnum } { bignum } define-primitive
 \ fixnum>bignum make-foldable
 
-\ float>bignum { float } { bignum } <effect> set-primitive-effect
+\ float>bignum { float } { bignum } define-primitive
 \ float>bignum make-foldable
 
-\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
+\ fixnum>float { fixnum } { float } define-primitive
 \ fixnum>float make-foldable
 
-\ bignum>float { bignum } { float } <effect> set-primitive-effect
+\ bignum>float { bignum } { float } define-primitive
 \ bignum>float make-foldable
 
-\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
+\ <ratio> { integer integer } { ratio } define-primitive
 \ <ratio> make-foldable
 
-\ string>float { string } { float } <effect> set-primitive-effect
+\ string>float { string } { float } define-primitive
 \ string>float make-foldable
 
-\ float>string { float } { string } <effect> set-primitive-effect
+\ float>string { float } { string } define-primitive
 \ float>string make-foldable
 
-\ float>bits { real } { integer } <effect> set-primitive-effect
+\ float>bits { real } { integer } define-primitive
 \ float>bits make-foldable
 
-\ double>bits { real } { integer } <effect> set-primitive-effect
+\ double>bits { real } { integer } define-primitive
 \ double>bits make-foldable
 
-\ bits>float { integer } { float } <effect> set-primitive-effect
+\ bits>float { integer } { float } define-primitive
 \ bits>float make-foldable
 
-\ bits>double { integer } { float } <effect> set-primitive-effect
+\ bits>double { integer } { float } define-primitive
 \ bits>double make-foldable
 
-\ <complex> { real real } { complex } <effect> set-primitive-effect
+\ <complex> { real real } { complex } define-primitive
 \ <complex> make-foldable
 
-\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum+ { fixnum fixnum } { integer } define-primitive
 \ fixnum+ make-foldable
 
-\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum+fast make-foldable
 
-\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum- { fixnum fixnum } { integer } define-primitive
 \ fixnum- make-foldable
 
-\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-fast make-foldable
 
-\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum* { fixnum fixnum } { integer } define-primitive
 \ fixnum* make-foldable
 
-\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum*fast make-foldable
 
-\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum/i { fixnum fixnum } { integer } define-primitive
 \ fixnum/i make-foldable
 
-\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-mod make-foldable
 
-\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
+\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive
 \ fixnum/mod make-foldable
 
-\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-bitand make-foldable
 
-\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-bitor make-foldable
 
-\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-bitxor make-foldable
 
-\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitnot { fixnum } { fixnum } define-primitive
 \ fixnum-bitnot make-foldable
 
-\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum-shift { fixnum fixnum } { integer } define-primitive
 \ fixnum-shift make-foldable
 
-\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-shift-fast make-foldable
 
-\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum= { bignum bignum } { object } define-primitive
 \ bignum= make-foldable
 
-\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum+ { bignum bignum } { bignum } define-primitive
 \ bignum+ make-foldable
 
-\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum- { bignum bignum } { bignum } define-primitive
 \ bignum- make-foldable
 
-\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum* { bignum bignum } { bignum } define-primitive
 \ bignum* make-foldable
 
-\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum/i { bignum bignum } { bignum } define-primitive
 \ bignum/i make-foldable
 
-\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-mod { bignum bignum } { bignum } define-primitive
 \ bignum-mod make-foldable
 
-\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
+\ bignum/mod { bignum bignum } { bignum bignum } define-primitive
 \ bignum/mod make-foldable
 
-\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitand { bignum bignum } { bignum } define-primitive
 \ bignum-bitand make-foldable
 
-\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitor { bignum bignum } { bignum } define-primitive
 \ bignum-bitor make-foldable
 
-\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitxor { bignum bignum } { bignum } define-primitive
 \ bignum-bitxor make-foldable
 
-\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitnot { bignum } { bignum } define-primitive
 \ bignum-bitnot make-foldable
 
-\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-shift { bignum bignum } { bignum } define-primitive
 \ bignum-shift make-foldable
 
-\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum< { bignum bignum } { object } define-primitive
 \ bignum< make-foldable
 
-\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum<= { bignum bignum } { object } define-primitive
 \ bignum<= make-foldable
 
-\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum> { bignum bignum } { object } define-primitive
 \ bignum> make-foldable
 
-\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum>= { bignum bignum } { object } define-primitive
 \ bignum>= make-foldable
 
-\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
+\ bignum-bit? { bignum integer } { object } define-primitive
 \ bignum-bit? make-foldable
 
-\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
+\ bignum-log2 { bignum } { bignum } define-primitive
 \ bignum-log2 make-foldable
 
-\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
+\ byte-array>bignum { byte-array } { bignum } define-primitive
 \ byte-array>bignum make-foldable
 
-\ float= { float float } { object } <effect> set-primitive-effect
+\ float= { float float } { object } define-primitive
 \ float= make-foldable
 
-\ float+ { float float } { float } <effect> set-primitive-effect
+\ float+ { float float } { float } define-primitive
 \ float+ make-foldable
 
-\ float- { float float } { float } <effect> set-primitive-effect
+\ float- { float float } { float } define-primitive
 \ float- make-foldable
 
-\ float* { float float } { float } <effect> set-primitive-effect
+\ float* { float float } { float } define-primitive
 \ float* make-foldable
 
-\ float/f { float float } { float } <effect> set-primitive-effect
+\ float/f { float float } { float } define-primitive
 \ float/f make-foldable
 
-\ float< { float float } { object } <effect> set-primitive-effect
+\ float< { float float } { object } define-primitive
 \ float< make-foldable
 
-\ float-mod { float float } { float } <effect> set-primitive-effect
+\ float-mod { float float } { float } define-primitive
 \ float-mod make-foldable
 
-\ float<= { float float } { object } <effect> set-primitive-effect
+\ float<= { float float } { object } define-primitive
 \ float<= make-foldable
 
-\ float> { float float } { object } <effect> set-primitive-effect
+\ float> { float float } { object } define-primitive
 \ float> make-foldable
 
-\ float>= { float float } { object } <effect> set-primitive-effect
+\ float>= { float float } { object } define-primitive
 \ float>= make-foldable
 
-\ <word> { object object } { word } <effect> set-primitive-effect
+\ <word> { object object } { word } define-primitive
 \ <word> make-flushable
 
-\ word-xt { word } { integer integer } <effect> set-primitive-effect
+\ word-xt { word } { integer integer } define-primitive
 \ word-xt make-flushable
 
-\ getenv { fixnum } { object } <effect> set-primitive-effect
+\ getenv { fixnum } { object } define-primitive
 \ getenv make-flushable
 
-\ setenv { object fixnum } { } <effect> set-primitive-effect
+\ setenv { object fixnum } { } define-primitive
 
-\ (exists?) { string } { object } <effect> set-primitive-effect
+\ (exists?) { string } { object } define-primitive
 
-\ (directory) { string } { array } <effect> set-primitive-effect
+\ (directory) { string } { array } define-primitive
 
-\ gc { } { } <effect> set-primitive-effect
+\ gc { } { } define-primitive
 
-\ gc-stats { } { array } <effect> set-primitive-effect
+\ gc-stats { } { array } define-primitive
 
-\ save-image { string } { } <effect> set-primitive-effect
+\ save-image { string } { } define-primitive
 
-\ save-image-and-exit { string } { } <effect> set-primitive-effect
+\ save-image-and-exit { string } { } define-primitive
 
-\ exit { integer } { } <effect> t >>terminated? set-primitive-effect
+\ data-room { } { integer integer array } define-primitive
-
-\ data-room { } { integer integer array } <effect> set-primitive-effect
 \ data-room make-flushable
 
-\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
+\ code-room { } { integer integer integer integer } define-primitive
 \ code-room  make-flushable
 
-\ os-env { string } { object } <effect> set-primitive-effect
+\ os-env { string } { object } define-primitive
 
-\ millis { } { integer } <effect> set-primitive-effect
+\ millis { } { integer } define-primitive
 \ millis make-flushable
 
-\ tag { object } { fixnum } <effect> set-primitive-effect
+\ tag { object } { fixnum } define-primitive
 \ tag make-foldable
 
-\ cwd { } { string } <effect> set-primitive-effect
+\ dlopen { string } { dll } define-primitive
 
-\ cd { string } { } <effect> set-primitive-effect
+\ dlsym { string object } { c-ptr } define-primitive
 
-\ dlopen { string } { dll } <effect> set-primitive-effect
+\ dlclose { dll } { } define-primitive
 
-\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
+\ <byte-array> { integer } { byte-array } define-primitive
-
-\ dlclose { dll } { } <effect> set-primitive-effect
-
-\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
 \ <byte-array> make-flushable
 
-\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
+\ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive
 \ <displaced-alien> make-flushable
 
-\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-cell { c-ptr integer } { integer } define-primitive
 \ alien-signed-cell make-flushable
 
-\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-cell { c-ptr integer } { integer } define-primitive
 \ alien-unsigned-cell make-flushable
 
-\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-8 { c-ptr integer } { integer } define-primitive
 \ alien-signed-8 make-flushable
 
-\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-8 { c-ptr integer } { integer } define-primitive
 \ alien-unsigned-8 make-flushable
 
-\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-4 { c-ptr integer } { integer } define-primitive
 \ alien-signed-4 make-flushable
 
-\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-4 { c-ptr integer } { integer } define-primitive
 \ alien-unsigned-4 make-flushable
 
-\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-2 { c-ptr integer } { fixnum } define-primitive
 \ alien-signed-2 make-flushable
 
-\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive
 \ alien-unsigned-2 make-flushable
 
-\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-1 { c-ptr integer } { fixnum } define-primitive
 \ alien-signed-1 make-flushable
 
-\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive
 \ alien-unsigned-1 make-flushable
 
-\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive
 
-\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-float { c-ptr integer } { float } define-primitive
 \ alien-float make-flushable
 
-\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-float { float c-ptr integer } { } define-primitive
 
-\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-double { c-ptr integer } { float } define-primitive
 \ alien-double make-flushable
 
-\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-double { float c-ptr integer } { } define-primitive
 
-\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
+\ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
 \ alien-cell make-flushable
 
-\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
 
-\ alien-address { alien } { integer } <effect> set-primitive-effect
+\ alien-address { alien } { integer } define-primitive
 \ alien-address make-flushable
 
-\ slot { object fixnum } { object } <effect> set-primitive-effect
+\ slot { object fixnum } { object } define-primitive
 \ slot make-flushable
 
-\ set-slot { object object fixnum } { } <effect> set-primitive-effect
+\ set-slot { object object fixnum } { } define-primitive
 
-\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
+\ string-nth { fixnum string } { fixnum } define-primitive
 \ string-nth make-flushable
 
-\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
+\ set-string-nth { fixnum fixnum string } { } define-primitive
 
-\ resize-array { integer array } { array } <effect> set-primitive-effect
+\ resize-array { integer array } { array } define-primitive
 \ resize-array make-flushable
 
-\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
+\ resize-byte-array { integer byte-array } { byte-array } define-primitive
 \ resize-byte-array make-flushable
 
-\ resize-string { integer string } { string } <effect> set-primitive-effect
+\ resize-string { integer string } { string } define-primitive
 \ resize-string make-flushable
 
-\ <array> { integer object } { array } <effect> set-primitive-effect
+\ <array> { integer object } { array } define-primitive
 \ <array> make-flushable
 
-\ begin-scan { } { } <effect> set-primitive-effect
+\ begin-scan { } { } define-primitive
 
-\ next-object { } { object } <effect> set-primitive-effect
+\ next-object { } { object } define-primitive
 
-\ end-scan { } { } <effect> set-primitive-effect
+\ end-scan { } { } define-primitive
 
-\ size { object } { fixnum } <effect> set-primitive-effect
+\ size { object } { fixnum } define-primitive
 \ size make-flushable
 
-\ die { } { } <effect> set-primitive-effect
+\ die { } { } define-primitive
 
-\ fopen { string string } { alien } <effect> set-primitive-effect
+\ fopen { string string } { alien } define-primitive
 
-\ fgetc { alien } { object } <effect> set-primitive-effect
+\ fgetc { alien } { object } define-primitive
 
-\ fwrite { string alien } { } <effect> set-primitive-effect
+\ fwrite { string alien } { } define-primitive
 
-\ fputc { object alien } { } <effect> set-primitive-effect
+\ fputc { object alien } { } define-primitive
 
-\ fread { integer string } { object } <effect> set-primitive-effect
+\ fread { integer string } { object } define-primitive
 
-\ fflush { alien } { } <effect> set-primitive-effect
+\ fflush { alien } { } define-primitive
 
-\ fclose { alien } { } <effect> set-primitive-effect
+\ fclose { alien } { } define-primitive
 
-\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
+\ <wrapper> { object } { wrapper } define-primitive
 \ <wrapper> make-foldable
 
-\ (clone) { object } { object } <effect> set-primitive-effect
+\ (clone) { object } { object } define-primitive
 \ (clone) make-flushable
 
-\ <string> { integer integer } { string } <effect> set-primitive-effect
+\ <string> { integer integer } { string } define-primitive
 \ <string> make-flushable
 
-\ array>quotation { array } { quotation } <effect> set-primitive-effect
+\ array>quotation { array } { quotation } define-primitive
 \ array>quotation make-flushable
 
-\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
+\ quotation-xt { quotation } { integer } define-primitive
 \ quotation-xt make-flushable
 
-\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
+\ <tuple> { tuple-layout } { tuple } define-primitive
 \ <tuple> make-flushable
 
-\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
+\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } define-primitive
 \ <tuple-layout> make-foldable
 
-\ datastack { } { array } <effect> set-primitive-effect
+\ datastack { } { array } define-primitive
 \ datastack make-flushable
 
-\ retainstack { } { array } <effect> set-primitive-effect
+\ retainstack { } { array } define-primitive
 \ retainstack make-flushable
 
-\ callstack { } { callstack } <effect> set-primitive-effect
+\ callstack { } { callstack } define-primitive
 \ callstack make-flushable
 
-\ callstack>array { callstack } { array } <effect> set-primitive-effect
+\ callstack>array { callstack } { array } define-primitive
 \ callstack>array make-flushable
 
-\ (sleep) { integer } { } <effect> set-primitive-effect
+\ (sleep) { integer } { } define-primitive
 
-\ become { array array } { } <effect> set-primitive-effect
+\ become { array array } { } define-primitive
 
-\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
+\ innermost-frame-quot { callstack } { quotation } define-primitive
 
-\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
+\ innermost-frame-scan { callstack } { fixnum } define-primitive
 
-\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
+\ set-innermost-frame-quot { quotation callstack } { } define-primitive
 
-\ (os-envs) { } { array } <effect> set-primitive-effect
+\ (os-envs) { } { array } define-primitive
 
-\ set-os-env { string string } { } <effect> set-primitive-effect
+\ set-os-env { string string } { } define-primitive
 
-\ unset-os-env { string } { } <effect> set-primitive-effect
+\ unset-os-env { string } { } define-primitive
 
-\ (set-os-envs) { array } { } <effect> set-primitive-effect
+\ (set-os-envs) { array } { } define-primitive
 
 \ do-primitive [ \ do-primitive cannot-infer-effect ] +infer+ set-word-prop
 
-\ dll-valid? { object } { object } <effect> set-primitive-effect
+\ dll-valid? { object } { object } define-primitive
 
-\ modify-code-heap { array object } { } <effect> set-primitive-effect
+\ modify-code-heap { array object } { } define-primitive
 
-\ unimplemented { } { } <effect> set-primitive-effect
+\ unimplemented { } { } define-primitive

unfinished/stack-checker/stack-checker-tests.factor

@@ -9,6 +9,8 @@ threads.private io.streams.string io.timeouts io.thread
 sequences.private destructors combinators ;
 IN: stack-checker.tests
 
+\ infer. must-infer
+
 { 0 2 } [ 2 "Hello" ] must-infer-as
 { 1 2 } [ dup ] must-infer-as
 

unfinished/stack-checker/transforms/transforms.factor

@@ -3,24 +3,43 @@
 USING: fry accessors arrays kernel words sequences generic math
 namespaces quotations assocs combinators classes.tuple
 classes.tuple.private effects summary hashtables classes generic
-sets definitions generic.standard slots.private
+sets definitions generic.standard slots.private continuations
 stack-checker.backend stack-checker.state stack-checker.errors ;
 IN: stack-checker.transforms
 
-: transform-quot ( quot n -- newquot )
+SYMBOL: +transform-quot+
+SYMBOL: +transform-n+
+
+: (apply-transform) ( quot n -- newquot )
     dup zero? [
-        drop '[ recursive-state get @ ]
+        drop recursive-state get 1array
     ] [
-        '[
+        consume-d
-            , consume-d
+        [ [ literal value>> ] map ]
-            [ first literal recursion>> ]
+        [ first literal recursion>> ] bi prefix
-            [ [ literal value>> ] each ] bi @
-        ]
     ] if
-    '[ @ swap infer-quot ] ;
+    swap with-datastack ;
+
+: apply-transform ( word -- )
+    [ +inlined+ depends-on ] [
+        [ +transform-quot+ word-prop ]
+        [ +transform-n+ word-prop ]
+        bi (apply-transform)
+        first2 swap infer-quot
+    ] bi ;
+
+: apply-macro ( word -- )
+    [ +inlined+ depends-on ] [
+        [ "macro" word-prop ]
+        [ "declared-effect" word-prop in>> length ]
+        bi (apply-transform)
+        first2 swap infer-quot
+    ] bi ;
 
 : define-transform ( word quot n -- )
-    transform-quot +infer+ set-word-prop ;
+    [ drop +transform-quot+ set-word-prop ]
+    [ nip +transform-n+ set-word-prop ]
+    3bi ;
 
 ! Combinators
 \ cond [ cond>quot ] 1 define-transform

unfinished/stack-checker/visitor/dummy/dummy.factor

@@ -16,7 +16,7 @@ M: f #terminate, ;
 M: f #if, 3drop ;
 M: f #dispatch, 2drop ;
 M: f #phi, 2drop 2drop ;
-M: f #declare, 3drop ;
+M: f #declare, drop ;
 M: f #recursive, drop drop drop drop drop ;
 M: f #copy, 2drop ;
 M: f #drop, drop ;

unfinished/stack-checker/visitor/visitor.factor

@@ -3,25 +3,25 @@
 USING: kernel arrays namespaces ;
 IN: stack-checker.visitor
 
-SYMBOL: dataflow-visitor
+SYMBOL: stack-visitor
 
-HOOK: child-visitor dataflow-visitor ( -- visitor )
+HOOK: child-visitor stack-visitor ( -- visitor )
 
-: nest-visitor ( -- ) child-visitor dataflow-visitor set ;
+: nest-visitor ( -- ) child-visitor stack-visitor set ;
 
-HOOK: #introduce, dataflow-visitor ( values -- )
+HOOK: #introduce, stack-visitor ( values -- )
-HOOK: #call, dataflow-visitor ( inputs outputs word -- )
+HOOK: #call, stack-visitor ( inputs outputs word -- )
-HOOK: #call-recursive, dataflow-visitor ( inputs outputs word -- )
+HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
-HOOK: #push, dataflow-visitor ( literal value -- )
+HOOK: #push, stack-visitor ( literal value -- )
-HOOK: #shuffle, dataflow-visitor ( inputs outputs mapping -- )
+HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
-HOOK: #drop, dataflow-visitor ( values -- )
+HOOK: #drop, stack-visitor ( values -- )
-HOOK: #>r, dataflow-visitor ( inputs outputs -- )
+HOOK: #>r, stack-visitor ( inputs outputs -- )
-HOOK: #r>, dataflow-visitor ( inputs outputs -- )
+HOOK: #r>, stack-visitor ( inputs outputs -- )
-HOOK: #terminate, dataflow-visitor ( -- )
+HOOK: #terminate, stack-visitor ( -- )
-HOOK: #if, dataflow-visitor ( ? true false -- )
+HOOK: #if, stack-visitor ( ? true false -- )
-HOOK: #dispatch, dataflow-visitor ( n branches -- )
+HOOK: #dispatch, stack-visitor ( n branches -- )
-HOOK: #phi, dataflow-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
+HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
-HOOK: #declare, dataflow-visitor ( inputs outputs declaration -- )
+HOOK: #declare, stack-visitor ( declaration -- )
-HOOK: #return, dataflow-visitor ( label stack -- )
+HOOK: #return, stack-visitor ( label stack -- )
-HOOK: #recursive, dataflow-visitor ( word label inputs outputs visitor -- )
+HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
-HOOK: #copy, dataflow-visitor ( inputs outputs -- )
+HOOK: #copy, stack-visitor ( inputs outputs -- )