steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2008-07-24 10:35:21 -05:00
parent 12914606af bba0ff79c5
commit f9a8612b56
87 changed files with 2704 additions and 1129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/classes/algebra/algebra-tests.factor
View File

@ -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= ;

3
core/classes/algebra/algebra.factor
View File

@ -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* ;

9
core/combinators/combinators-docs.factor
View File

@ -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." } ;

6
core/combinators/combinators.factor
View File

@ -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

11
core/continuations/continuations-docs.factor
View File

@ -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 }" }
} ;

4
core/continuations/continuations-tests.factor
View File

@ -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

8
core/continuations/continuations.factor
View File

@ -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

10
core/generic/math/math.factor
View File

@ -22,8 +22,14 @@ PREDICATE: math-class < class
[ drop { 100 100 } ]
} cond ;
: math-class-max ( class class -- class )
[ [ math-precedence ] compare +gt+ eq? ] most ;
: math-class<=> ( class1 class2 -- class )
[ 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 ;

10
core/inference/transforms/transforms-tests.factor
View File

@ -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

10
core/kernel/kernel.factor
View File

@ -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

61
core/math/intervals/intervals-docs.factor
View File

@ -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 } } }
{ $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." } ;
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
{ $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 } } }
{ $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." } ;
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
{ $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 } }

136
core/math/intervals/intervals-tests.factor
View File

@ -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 ( -- ? )
random-interval random-interval random-op ! 3dup . . .
0 pick interval-contains? over first { / /i } member? and [
: binary-test ( -- ? )
random-interval random-interval random-binary-op ! 3dup . . .
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? [
2drop t
] [
=
] if ;
second execute dup incomparable eq? [ 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

268
core/math/intervals/intervals.factor
View File

@ -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
>r [ first ] bi@ r> call
r> r> [ second ] both? 2array ; inline
[ [ first ] [ first ] [ ] tri* call ]
[ drop [ second ] both? ]
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 )
>r 2dup
[ interval>points [ first integer? ] both? ] both?
r> [ 2drop f ] if ; inline
: interval* ( i1 i2 -- i3 )
[ [ * ] interval-op ] do-empty-interval ;
: 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> ]
: 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 ] 2bi*
<interval>
] [
or
] if
]
} cond ;
: interval-intersect ( i1 i2 -- i3 )
2dup and [
[ interval>points ] bi@ swapd
[ swap endpoint> ] most
>r [ swap endpoint< ] most r>
make-interval
] [
or
] if ;
: interval-union ( i1 i2 -- i3 )
2dup and [
[ interval>points 2array ] bi@ append points>interval
] [
2drop f
] if ;
{
{ [ dup empty-interval eq? ] [ drop ] }
{ [ over empty-interval eq? ] [ nip ] }
[
2dup and [
[ interval>points 2array ] bi@ append points>interval
] [
2drop f
] 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 -- ? )
interval>points
2dup [ second ] bi@ and
[ [ first ] bi@ = ]
[ 2drop f ] if ;
dup empty-interval eq? [
drop f
] [
interval>points
2dup [ second ] bi@ and
[ [ first ] bi@ = ]
[ 2drop f ] if
] if ;
: interval-length ( int -- n )
dup
[ interval>points [ first ] bi@ swap - ]
[ drop 0 ] if ;
{
{ [ dup empty-interval eq? ] [ drop 0 ] }
{ [ dup not ] [ drop 0 ] }
[ interval>points [ first ] bi@ swap - ]
} 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
] [
interval-shift
] if ;
[
dup to>> first 100 > [
2drop [-inf,inf]
] [
interval-shift
] 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
[ nip interval-singleton? ] 2keep
[ from>> ] bi@ =
and and ;
[ swap interval-subset? ]
[ nip interval-singleton? ]
[ [ from>> ] bi@ = ]
2tri and and ;
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ] 2keep
[ drop interval-singleton? ] 2keep
[ to>> ] bi@ =
and and ;
[ interval-subset? ]
[ drop interval-singleton? ]
[ [ to>> ] bi@ = ]
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 )
[ from>> first2 [ 1+ ] unless ]
[ to>> first2 [ 1- ] unless ]
bi [a,b] ;
dup empty-interval eq? [
[ from>> first2 [ 1+ ] unless ]
[ to>> first2 [ 1- ] unless ]
bi [a,b]
] unless ;

28
core/math/math-docs.factor
View File

@ -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 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."
"Modulus of bignums always yields a bignum."
"Given fixnums, always yields a fixnum."
"Given bignums, always yields a bignum."
"Given rationals, always yields a rational."
}
}
{ $see-also "division-by-zero" mod } ;

2
core/math/math.factor
View File

@ -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

2
core/math/parser/parser-tests.factor
View File

@ -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

10
core/sequences/sequences.factor
View File

@ -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>
[ [ collect ] keep ] new-like ; inline
>r 2over min-length r>
[ [ 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

38
extra/24-game/24-game.factor Normal file
View File

@ -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 ;

2
extra/locals/backend/backend.factor
View File

@ -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

9
extra/math/derivatives/derivatives-docs.factor Normal file
View File

@ -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

9
extra/math/derivatives/derivatives.factor Normal file
View File

@ -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 ;

8
extra/math/function-tools/function-tools.factor Normal file
View File

@ -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 ;

3
extra/math/geometry/geometry.factor
View File

@ -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 )

3
extra/math/geometry/rect/rect.factor
View File

@ -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 ;

2
extra/math/matrices/elimination/elimination.factor
View File

@ -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 ;

11
extra/math/newtons-method/newtons-method.factor Normal file
View File

@ -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 ;

9
extra/math/points/points.factor
View File

@ -1,5 +1,4 @@
USING: kernel arrays math.vectors ;
USING: kernel arrays math.vectors sequences math ;
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 / - ;

2
extra/math/ratios/ratios.factor
View File

@ -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 ;

14
extra/math/secant-method/secant-method.factor Normal file
View File

@ -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 ;

2
extra/project-euler/ave-time/ave-time.factor
View File

@ -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 )

9
extra/slides/slides.factor
View File

@ -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 } } }
over set-gadget-interior
{ 800 10 } over set-gadget-dim
{ 1 0 } over set-gadget-orientation
T{ gradient f { { 0.25 0.25 0.25 1.0 } { 1.0 1.0 1.0 0.0 } } } >>interior
{ 800 10 } >>dim
{ 1 0 } >>orientation
gadget.
] ($block) ;

2
extra/ui/cocoa/views/views.factor
View File

@ -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
]
}

2
extra/ui/gadgets/books/books.factor
View File

@ -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 ;

2
extra/ui/gadgets/borders/borders.factor
View File

@ -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 ;

4
extra/ui/gadgets/buttons/buttons.factor
View File

@ -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 ;

10
extra/ui/gadgets/gadgets-docs.factor
View File

@ -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." }

18
extra/ui/gadgets/gadgets.factor
View File

@ -165,16 +165,16 @@ DEFER: relayout
: hide-gadget ( gadget -- ) f swap (>>visible?) ;
: (set-rect-dim) ( dim gadget quot -- )
>r 2dup rect-dim =
[ [ 2drop ] [ set-rect-dim ] if ] 2keep
[ drop ] r> if ; inline
DEFER: in-layout?
: set-layout-dim ( dim gadget -- )
[ invalidate ] (set-rect-dim) ;
: do-invalidate ( gadget -- gadget )
in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
: set-gadget-dim ( dim gadget -- )
[ invalidate* ] (set-rect-dim) ;
M: gadget (>>dim) ( dim gadget -- )
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) ;

2
extra/ui/gadgets/grids/grids.factor
View File

@ -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 ;

2
extra/ui/gadgets/packs/packs.factor
View File

@ -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 )

2
extra/ui/gadgets/sliders/sliders.factor
View File

@ -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 ;

153
extra/ui/gadgets/tiling/tiling.factor Normal file
View File

@ -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

12
extra/ui/gadgets/tracks/tracks.factor
View File

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

2
extra/ui/gadgets/viewports/viewports.factor
View File

@ -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 ;

2
extra/ui/gadgets/worlds/worlds.factor
View File

@ -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 ;

3
extra/ui/gadgets/wrappers/wrappers.factor
View File

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

4
extra/ui/ui-docs.factor
View File

@ -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-gadget-dim } ;
{ $subsection set-rect-loc } ;
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 }

4
extra/ui/ui.factor
View File

@ -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 ;

2
extra/ui/windows/windows.factor
View File

@ -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

2
extra/ui/x11/x11.factor
View File

@ -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 ;

17
unfinished/compiler/frontend/frontend-tests.factor
View File

@ -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

79
unfinished/compiler/frontend/frontend.factor
View File

@ -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 ;

10
unfinished/compiler/frontend/frontend-docs.factor → unfinished/compiler/tree/builder/builder-docs.factor
View File

@ -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

6
unfinished/compiler/tree/builder/builder-tests.factor Normal file
View File

@ -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

99
unfinished/compiler/tree/builder/builder.factor
View File

@ -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
stack-checker.visitor ;
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 ;
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 -- )
dataflow-visitor get swap
over last>>
[ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
[ [ >>first ] [ >>last ] bi drop ]
if ;
GENERIC# build-tree-with 1 ( quot stack -- dataflow )
M: tree-builder child-visitor tree-builder new ;
M: tree-builder #introduce, #introduce node, ;
M: tree-builder #call, #call node, ;
M: tree-builder #call-recursive, #call-recursive node, ;
M: tree-builder #push, #push node, ;
M: tree-builder #shuffle, #shuffle node, ;
M: tree-builder #drop, #drop node, ;
M: tree-builder #>r, #>r node, ;
M: tree-builder #r>, #r> node, ;
M: tree-builder #return, #return node, ;
M: tree-builder #terminate, #terminate node, ;
M: tree-builder #if, [ first>> ] bi@ #if node, ;
M: tree-builder #dispatch, [ first>> ] map #dispatch node, ;
M: tree-builder #phi, #phi node, ;
M: tree-builder #declare, #declare node, ;
M: tree-builder #recursive, first>> #recursive node, ;
M: tree-builder #copy, #copy node, ;
M: callable build-tree-with
#! Not safe to call from inference transforms.
[
>vector meta-d set
f infer-quot
] with-tree-builder nip ;
: build-tree ( quot -- dataflow ) f build-tree-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 ;
: 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 ;

17
unfinished/compiler/tree/combinators/combinators-tests.factor Normal file
View File

@ -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

26
unfinished/compiler/tree/combinators/combinators.factor
View File

@ -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 [
over children>> [
'[ , map ] change-children drop
] [
2drop
] if
] [
2drop
] if ; inline
[ children>> ] dip '[ , change-first drop ] each ; inline
: (transform-nodes) ( prev node quot -- )
dup >r call dup [

50
unfinished/compiler/tree/comparisons/comparisons.factor Normal file
View File

@ -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 ;

42
unfinished/compiler/tree/copy-equiv/copy-equiv.factor Normal file
View File

@ -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 ;

4
unfinished/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -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

174
unfinished/compiler/tree/dead-code/dead-code.factor
View File

@ -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
compiler.tree.combinators compiler.tree.def-use ;
kernel sequences words sets stack-checker.inlining
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.
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 ;
! outputs are unused using backward DFA.
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 ] [
[ look-at-inputs ]
[ look-at-outputs ]
bi
] if ;
dup word>> "flushable" word-prop
[ drop ] [ [ look-at-inputs ] [ 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>>
[ drop ] [ look-at-inputs ] if ;
dup label>> [ drop ] [ look-at-inputs ] if ;
M: node mark-live-values drop ;
GENERIC: propagate* ( value node -- )
SYMBOL: live-values
M: #copy propagate*
#! 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 ;
: live-value? ( value -- ? ) live-values get at ;
: compute-live-values ( node -- )
#! We add f initially because #phi nodes can have f in their
#! 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 ;
[ mark-live-values ] backward-dfa live-values set ;
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 )
over >r call [ r> successor>> ] [ r> drop t ] if ;
inline
M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
M: #shuffle remove-dead-nodes*
[ in-d>> empty? ] prune-if ;
M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
M: #push remove-dead-nodes*
[ out-d>> empty? ] prune-if ;
M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
M: #>r remove-dead-nodes*
[ in-d>> empty? ] prune-if ;
M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
M: #r> remove-dead-nodes*
[ in-r>> empty? ] prune-if ;
M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
: (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 )
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 ;
M: f remove-dead-nodes* drop t ;
: remove-dead-code ( node -- newnode )
[
[ compute-live-values ]
[ [ (remove-dead-code) ] transform-nodes ] bi
] with-scope ;
[ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;

6
unfinished/compiler/tree/def-use/def-use-tests.factor
View File

@ -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

14
unfinished/compiler/tree/def-use/def-use.factor
View File

@ -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-defs-values [ def-value ] each-value ] bi ;
[ dup node-uses-values [ use-value ] with each ]
[ dup node-defs-values [ def-value ] with each ] bi ;
: check-def-use ( -- )
def-use get [

40
unfinished/compiler/tree/dfa/backward/backward.factor Normal file
View File

@ -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

40
unfinished/compiler/tree/dfa/dfa.factor Normal file
View File

@ -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

88
unfinished/compiler/tree/propagation/branches/branches.factor
View File

@ -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
[
\ f class-not 0 `input class,
f 0 `input literal,
] make-constraints ;
in-d>> first [ =t ] [ =f ] bi 2array ;
M: #dispatch child-constraints
dup [
children>> length [ 0 `input literal, ] each
] make-constraints ;
children>> length f <repetition> ;
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
value-literals [ clone ] change
value-intervals [ clone ] change
constraints [ clone ] change
apply-constraint
(propagate)
over [
value-infos [ clone ] change
constraints [ clone ] change
assume
first>> (propagate)
] [
2drop
value-infos off
constraints off
] if
] H{ } make-assoc
] 2map ;
: merge-classes ( inputs outputs results -- )
'[
, null
[ [ value-class ] bind class-or ] 2reduce
_ set-value-class
] 2each ;
: (merge-value-infos) ( inputs results -- infos )
'[ , [ [ value-info ] bind ] 2map value-infos-union ] map ;
: merge-intervals ( inputs outputs results -- )
'[
, [ [ value-interval ] bind ] 2map
dup first [ interval-union ] reduce
_ set-value-interval
] 2each ;
: merge-value-infos ( results inputs outputs -- )
[ swap (merge-value-infos) ] dip set-value-infos ;
: merge-literals ( inputs outputs results -- )
'[
, [ [ value-literal 2array ] bind ] 2map
dup all-eq? [ first first2 ] [ drop f f ] if
_ swap [ set-value-literal ] [ 2drop ] if
] 2each ;
: propagate-branch-phi ( results #phi -- )
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
2bi ;
: merge-stuff ( inputs outputs results -- )
[ merge-classes ] [ merge-intervals ] [ merge-literals ] 3tri ;
:: branch-phi-constraints ( x #phi -- )
#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? [
[ [ phi-in-d>> ] [ out-d>> ] bi rot merge-stuff ]
[ [ phi-in-r>> ] [ out-r>> ] bi rot merge-stuff ]
2bi
] [ 2drop ] if ;
[ successor>> propagate-branch-phi ]
[ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ]
bi ;
M: #branch propagate-around
[ infer-children ] [ merge-children ] [ annotate-node ] tri ;

202
unfinished/compiler/tree/propagation/constraints/constraints.factor
View File

@ -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
! infinite loop on circular data
GENERIC: eql? ( obj1 obj2 -- ? )
M: object eql? eq? ;
M: number eql? number= ;
! Maps constraints to constraints
! Maps constraints to constraints ("A implies B")
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?
over literal-constraint? [
[ [ literal>> ] bi@ eql? ]
[ [ value>> ] bi@ = ]
2bi and
] [ 2drop f ] if ;
: =t ( value -- constriant ) resolve-copy true-constraint boa ;
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 -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
: =f ( value -- constriant ) resolve-copy false-constraint boa ;
: `input ( n -- value ) node get in-d>> nth ;
: `output ( n -- value ) node get out-d>> nth ;
: class, ( class value -- ) <class-constraint> , ;
: literal, ( literal value -- ) <literal-constraint> , ;
: interval, ( interval value -- ) <interval-constraint> , ;
M: false-constraint assume
[ constraints get at [ assume ] when* ]
[ \ f <class-info> swap value>> refine-value-info ]
bi ;
M: f apply-constraint drop ;
M: false-constraint satisfied?
value>> value-info class>> \ f class<= ;
: make-constraints ( node quot -- constraint )
[ swap node set call ] { } make ; inline
M: false-constraint satisfiable?
value>> value-info class>> \ f classes-intersect? ;
: set-constraints ( node quot -- )
make-constraints
unclip [ 2array ] reduce
apply-constraint ; inline
! Class constraints
TUPLE: class-constraint value class ;
: assume ( constraint -- )
constraints get at [ apply-constraint ] when* ;
: is-instance-of ( value class -- constraint )
[ resolve-copy ] dip class-constraint boa ;
! Disjoint set of copy equivalence
SYMBOL: copies
M: class-constraint assume
[ 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
SYMBOL: value-literals
: is-equal-to ( value literal -- constraint )
[ resolve-copy ] dip literal-constraint boa ;
! Current value --> interval mapping
SYMBOL: value-intervals
M: literal-constraint assume
[ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
! Current value --> class mapping
SYMBOL: value-classes
! Implication constraints
TUPLE: implication p q ;
: value-interval ( value -- interval/f )
resolve-copy value-intervals get at ;
C: --> implication
: set-value-interval ( interval value -- )
resolve-copy value-intervals get set-at ;
: 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
M: implication assume
[ q>> ] [ p>> ] bi
[ constraints get set-at ]
[ constraint-satisfied? [ apply-constraint ] [ drop ] if ] 2bi ;
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: pair constraint-satisfied?
first constraint-satisfied? ;
M: implication satisfiable?
[ 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* /\ ;

63
unfinished/compiler/tree/propagation/info/info-tests.factor Normal file
View File

@ -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

146
unfinished/compiler/tree/propagation/info/info.factor Normal file
View File

@ -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 ;

239
unfinished/compiler/tree/propagation/known-words/known-words.factor Normal file
View File

@ -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

21
unfinished/compiler/tree/propagation/nodes/nodes.factor Normal file
View File

@ -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* ;

234
unfinished/compiler/tree/propagation/propagation-tests.factor Normal file
View File

@ -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

29
unfinished/compiler/tree/propagation/propagation.factor
View File

@ -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 -- )
[
[ node-defs-values [ introduce-value ] each ]
[ propagate-around ]
[ successor>> ]
tri
(propagate)
] when* ;
: propagate-with ( node classes literals intervals -- )
: propagate-with ( node infos -- )
[
H{ } clone constraints set
>hashtable value-intervals set
>hashtable value-literals set
>hashtable value-classes set
>hashtable value-infos 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
#! starting point.
[ classes>> ] [ literals>> ] [ intervals>> ] tri
propagate-with ;
info>> propagate-with ;

98
unfinished/compiler/tree/propagation/recursive/recursive.factor
View File

@ -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
! drop { f } ;
!
! M: #recursive propagate-around
! [ infer-children ] [ merge-children ] [ annotate-node ] tri ;
!
! : classes= ( inferred current -- ? )
! 2dup min-length '[ , tail* ] bi@ sequence= ;
!
! SYMBOL: fixed-point?
!
! SYMBOL: nested-labels
!
! : annotate-entry ( nodes #label -- )
! [ (merge-classes) ] dip node-child
! 2dup node-output-classes classes=
! [ 2drop ] [ set-classes fixed-point? off ] if ;
!
! : init-recursive-calls ( #label -- )
! #! We set recursive calls to output the empty type, then
! #! repeat inference until a fixed point is reached.
! #! Hopefully, our type functions are monotonic so this
! #! will always converge.
! returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
!
! M: #label propagate-before ( #label -- )
! [ 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 ;
! What if we reach a fixed point for the phi but not for the
! #call-label output?
! We need to compute scalar evolution so that sccp doesn't
! evaluate loops
: (merge-value-infos) ( inputs -- infos )
[ [ value-info ] map value-infos-union ] map ;
: merge-value-infos ( inputs outputs -- fixed-point? )
[ (merge-value-infos) ] dip
[ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ;
: propagate-recursive-phi ( #phi -- fixed-point? )
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
bi and ;
M: #recursive propagate-around ( #recursive -- )
dup
node-child
[ first>> (propagate) ] [ propagate-recursive-phi ] bi
[ drop ] [ propagate-around ] if ;
M: #call-recursive propagate-before ( #call-label -- )
[ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;

155
unfinished/compiler/tree/propagation/simple/simple.factor
View File

@ -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>> ] [ out-d>> ] bi [ intersect-value-class ] 2each ]
bi ;
declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
M: #shuffle propagate-before
[ out-r>> dup ] [ mapping>> ] bi '[ , at ] map are-copies-of ;
: predicate-constraints ( value class boolean-value -- constraint )
[ [ is-instance-of ] dip t--> ]
[ [ class-not is-instance-of ] dip f--> ]
3bi /\ ;
M: #>r propagate-before
[ in-d>> ] [ out-r>> ] bi are-copies-of ;
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 ;
: custom-constraints ( #call quot -- )
[ [ in-d>> ] [ out-d>> ] bi append ] dip
with-datastack first assume ;
: compute-constraints ( #call -- )
dup word>> "constraints" word-prop [
call
] [
dup word>> "predicating" word-prop dup
[ swap predicate-constraints ] [ 2drop ] if
dup word>> +constraints+ word-prop [ custom-constraints ] [
dup word>> predicate? [
[ in-d>> first ]
[ word>> "predicating" word-prop ]
[ out-d>> first ]
tri predicate-constraints assume
] [ drop ] if
] if* ;
: compute-output-classes ( node word -- classes intervals )
dup word>> "output-classes" word-prop
dup [ call ] [ 2drop f f ] if ;
: call-outputs-quot ( node -- infos )
[ in-d>> [ value-info ] map ]
[ word>> +outputs+ word-prop ]
bi with-datastack ;
: output-classes ( node -- classes intervals )
dup compute-output-classes [
[ ] [ word>> "default-output-classes" word-prop ] ?if
] dip ;
: foldable-call? ( #call -- ? )
dup word>> "foldable" word-prop [
in-d>> [ value-info literal?>> ] all?
] [
drop f
] if ;
: intersect-values ( classes intervals values -- )
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
: fold-call ( #call -- infos )
[ 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
#! value classes.
dup node-values {
[ value-intervals get valid-keys >>intervals ]
[ value-classes get valid-keys >>classes ]
[ value-literals get valid-keys >>literals ]
[ 2drop ]
} cleave ;
dup
[ node-defs-values ] [ node-uses-values ] bi append
[ dup value-info ] H{ } map>assoc
>>info drop ;
M: object propagate-around
{
[ propagate-before ]
[ annotate-node ]
[ propagate-after ]
} cleave ;
M: node propagate-around
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;

79
unfinished/compiler/tree/tree.factor
View File

@ -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
classes literals intervals
history successor children ;
in-d out-d in-r out-r info
successor children ;
M: node hashcode* drop node hashcode* ;
: node-shuffle ( node -- shuffle )
[ 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 ;
: node-child ( node -- child ) 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 -- ? )
swap literals>> key? ;
: node-value-info ( node value -- info )
swap info>> at ;
: node-literal ( node value -- obj )
swap literals>> at ;
: node-input-infos ( node -- seq )
dup in-d>> [ node-value-info ] with map ;
: node-interval ( node value -- interval )
swap intervals>> at ;
: 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 ;
: node-output-infos ( node -- seq )
dup out-d>> [ node-value-info ] with map ;
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 >>out-d
swap >>in-d ;
swap >>declaration ;
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, ;

50
unfinished/compiler/tree/untupling/untupling-tests.factor Normal file
View File

@ -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

59
unfinished/compiler/tree/untupling/untupling.factor Normal file
View File

@ -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 ;

12
unfinished/math/partial-dispatch/partial-dispatch-tests.factor Normal file
View File

@ -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

174
unfinished/math/partial-dispatch/partial-dispatch.factor Normal file
View File

@ -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

23
unfinished/stack-checker/backend/backend.factor
View File

@ -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

23
unfinished/stack-checker/branches/branches.factor
View File

@ -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 ;

7
unfinished/stack-checker/inlining/inlining.factor
View File

@ -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 ;

497
unfinished/stack-checker/known-words/known-words.factor
View File

@ -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
io.streams.c kernel kernel.private math math.private memory
namespaces namespaces.private parser prettyprint quotations
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
threads.private classes.tuple classes.tuple.private vectors
vectors.private words words.private assocs summary
compiler.units system.private
stack-checker.state stack-checker.backend stack-checker.branches
stack-checker.errors stack-checker.visitor ;
hashtables hashtables.private io io.backend io.files
io.files.private io.streams.c kernel kernel.private math
math.private memory namespaces namespaces.private parser
prettyprint quotations quotations.private sbufs sbufs.private
sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
combinators locals.backend stack-checker.state
stack-checker.backend stack-checker.branches
stack-checker.errors stack-checker.transforms
stack-checker.visitor ;
IN: stack-checker.known-words
: infer-shuffle ( shuffle -- )
[ 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, ;
: define-shuffle ( word shuffle -- )
'[ , infer-shuffle ] +infer+ set-word-prop ;
: infer-primitive ( word -- )
dup
[ "input-classes" word-prop ]
[ "default-output-classes" word-prop ] bi <effect>
apply-word/effect ;
{
{ 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
\ r> [ 1 infer-r> ] +infer+ set-word-prop
: infer-shuffle ( shuffle -- )
[ 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
#declare,
] +infer+ set-word-prop
[ length ensure-d ] keep zip
#declare, ;
! 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
\ call t "no-compile" set-word-prop
\ curry [
: infer-curry ( -- )
2 consume-d
dup first2 <curried> make-known
[ push-d ] [ 1array ] bi
\ curry #call,
] +infer+ set-word-prop
\ curry #call, ;
\ compose [
: infer-compose ( -- )
2 consume-d
dup first2 <composed> make-known
[ push-d ] [ 1array ] bi
\ compose #call,
] +infer+ set-word-prop
\ compose #call, ;
\ execute [
: infer-execute ( -- )
pop-literal nip
dup word? [
apply-object
] [
drop
"execute must be given a word" time-bomb
] if
] +infer+ set-word-prop
] if ;
\ execute t "no-compile" set-word-prop
\ 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> [
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
peek-d literal value>> size>> { tuple } <effect>
apply-word/effect
] +infer+ set-word-prop
apply-word/effect ;
! Non-standard control flow
\ (throw) [
: infer-(throw) ( -- )
\ (throw)
peek-d literal value>> 2 + f <effect> t >>terminated?
apply-word/effect
] +infer+ set-word-prop
apply-word/effect ;
: set-primitive-effect ( word effect -- )
[ in>> "input-classes" set-word-prop ]
[ out>> "default-output-classes" set-word-prop ]
[ dupd '[ , , apply-word/effect ] +infer+ set-word-prop ]
2tri ;
: infer-exit ( -- )
\ exit
{ integer } { } t >>terminated? <effect>
apply-word/effect ;
: 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 } <effect> set-primitive-effect
\ bignum>fixnum { bignum } { fixnum } define-primitive
\ 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 } <effect> set-primitive-effect
\ data-room { } { integer integer array } define-primitive
\ 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
\ dlclose { dll } { } <effect> set-primitive-effect
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
\ <byte-array> { integer } { byte-array } define-primitive
\ <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

2
unfinished/stack-checker/stack-checker-tests.factor
View File

@ -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

39
unfinished/stack-checker/transforms/transforms.factor
View File

@ -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
[ first literal recursion>> ]
[ [ literal value>> ] each ] bi @
]
consume-d
[ [ literal value>> ] map ]
[ first literal recursion>> ] bi prefix
] 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

2
unfinished/stack-checker/visitor/dummy/dummy.factor
View File

@ -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 ;

38
unfinished/stack-checker/visitor/visitor.factor
View File

@ -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: #call, dataflow-visitor ( inputs outputs word -- )
HOOK: #call-recursive, dataflow-visitor ( inputs outputs word -- )
HOOK: #push, dataflow-visitor ( literal value -- )
HOOK: #shuffle, dataflow-visitor ( inputs outputs mapping -- )
HOOK: #drop, dataflow-visitor ( values -- )
HOOK: #>r, dataflow-visitor ( inputs outputs -- )
HOOK: #r>, dataflow-visitor ( inputs outputs -- )
HOOK: #terminate, dataflow-visitor ( -- )
HOOK: #if, dataflow-visitor ( ? true false -- )
HOOK: #dispatch, dataflow-visitor ( n branches -- )
HOOK: #phi, dataflow-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
HOOK: #declare, dataflow-visitor ( inputs outputs declaration -- )
HOOK: #return, dataflow-visitor ( label stack -- )
HOOK: #recursive, dataflow-visitor ( word label inputs outputs visitor -- )
HOOK: #copy, dataflow-visitor ( inputs outputs -- )
HOOK: #introduce, stack-visitor ( values -- )
HOOK: #call, stack-visitor ( inputs outputs word -- )
HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
HOOK: #push, stack-visitor ( literal value -- )
HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
HOOK: #drop, stack-visitor ( values -- )
HOOK: #>r, stack-visitor ( inputs outputs -- )
HOOK: #r>, stack-visitor ( inputs outputs -- )
HOOK: #terminate, stack-visitor ( -- )
HOOK: #if, stack-visitor ( ? true false -- )
HOOK: #dispatch, stack-visitor ( n branches -- )
HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
HOOK: #declare, stack-visitor ( declaration -- )
HOOK: #return, stack-visitor ( label stack -- )
HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
HOOK: #copy, stack-visitor ( inputs outputs -- )