From 99522d1090325983334bc3cbed383dedc12f9863 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 26 Jul 2008 18:58:53 -0500 Subject: [PATCH 01/65] Print out 'recursive' declaration --- core/prettyprint/prettyprint.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 804895f6c4..4b5dd8542d 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -221,6 +221,7 @@ M: word declarations. POSTPONE: parsing POSTPONE: delimiter POSTPONE: inline + POSTPONE: recursive POSTPONE: foldable POSTPONE: flushable } [ declaration. ] with each ; From e5b9c8287eeb2765cea16e420d48bd7f07fbeb2b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 26 Jul 2008 19:01:43 -0500 Subject: [PATCH 02/65] Debugging slot propagation, starting recursive propagation --- .../tree/propagation/info/info-tests.factor | 2 + .../tree/propagation/info/info.factor | 26 +++++++- .../known-words/known-words.factor | 8 ++- .../tree/propagation/propagation-tests.factor | 64 ++++++++++++++++++- .../propagation/recursive/recursive.factor | 56 +++++++++++----- .../tree/propagation/slots/slots.factor | 55 ++++++++++------ 6 files changed, 172 insertions(+), 39 deletions(-) diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor index 41da9e6014..64d32ce458 100644 --- a/unfinished/compiler/tree/propagation/info/info-tests.factor +++ b/unfinished/compiler/tree/propagation/info/info-tests.factor @@ -61,3 +61,5 @@ IN: compiler.tree.propagation.info.tests 3 null value-info-union >literal< ] unit-test + +[ ] [ { } value-infos-union drop ] unit-test diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index dc24b58bce..6f78ba645e 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -113,6 +113,8 @@ slots ; DEFER: value-info-intersect +DEFER: (value-info-intersect) + : intersect-lengths ( info1 info2 -- length ) [ length>> ] bi@ { { [ dup not ] [ drop ] } @@ -120,10 +122,17 @@ DEFER: value-info-intersect [ value-info-intersect ] } cond ; +: intersect-slot ( info1 info2 -- info ) + { + { [ dup not ] [ nip ] } + { [ over not ] [ drop ] } + [ (value-info-intersect) ] + } cond ; + : intersect-slots ( info1 info2 -- slots ) [ slots>> ] bi@ 2dup [ length ] bi@ = - [ [ value-info-intersect ] 2map ] [ 2drop f ] if ; + [ [ intersect-slot ] 2map ] [ 2drop f ] if ; : (value-info-intersect) ( info1 info2 -- info ) [ ] 2dip @@ -150,6 +159,8 @@ DEFER: value-info-intersect DEFER: value-info-union +DEFER: (value-info-union) + : union-lengths ( info1 info2 -- length ) [ length>> ] bi@ { { [ dup not ] [ nip ] } @@ -157,10 +168,17 @@ DEFER: value-info-union [ value-info-union ] } cond ; +: union-slot ( info1 info2 -- info ) + { + { [ dup not ] [ nip ] } + { [ over not ] [ drop ] } + [ (value-info-union) ] + } cond ; + : union-slots ( info1 info2 -- slots ) [ slots>> ] bi@ 2dup [ length ] bi@ = - [ [ value-info-union ] 2map ] [ 2drop f ] if ; + [ [ union-slot ] 2map ] [ 2drop f ] if ; : (value-info-union) ( info1 info2 -- info ) [ ] 2dip @@ -181,7 +199,9 @@ DEFER: value-info-union } cond ; : value-infos-union ( infos -- info ) - dup first [ value-info-union ] reduce ; + dup empty? + [ drop null ] + [ dup first [ value-info-union ] reduce ] if ; ! Current value --> info mapping SYMBOL: value-infos diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor index bfdcff51c5..eef34f6f8f 100644 --- a/unfinished/compiler/tree/propagation/known-words/known-words.factor +++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor @@ -4,9 +4,10 @@ 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 +classes.tuple alien.accessors classes.tuple.private slots.private compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.constraints +compiler.tree.propagation.slots compiler.tree.comparisons ; IN: compiler.tree.propagation.known-words @@ -258,3 +259,8 @@ generic-comparison-ops [ ! the output of clone has the same type as the input { clone (clone) } [ [ ] +outputs+ set-word-prop ] each + +\ slot [ + dup literal?>> + [ literal>> swap value-info-slot ] [ 2drop object ] if +] +outputs+ set-word-prop diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 82f8ce1e4d..659f9d6e76 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -3,8 +3,8 @@ 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 -byte-arrays classes.algebra math.functions math.private -strings ; +byte-arrays classes.algebra classes.tuple.private +math.functions math.private strings layouts ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -235,12 +235,39 @@ IN: compiler.tree.propagation.tests [ [ 1 ] [ 1 ] if 1 + ] final-literals ] unit-test +[ V{ object } ] [ + [ 0 * 10 < ] final-classes +] unit-test + [ V{ string string } ] [ [ 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop ] final-classes ] unit-test +[ V{ float } ] [ + [ { real float } declare + ] final-classes +] unit-test + +[ V{ float } ] [ + [ { float real } declare + ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ { fixnum } declare 1 swap 7 bitand shift ] final-classes +] unit-test + +cell-bits 32 = [ + [ V{ integer } ] [ + [ { fixnum } declare 1 swap 31 bitand shift ] + final-classes + ] unit-test +] when + ! Array length propagation [ V{ t } ] [ [ 10 f length 10 = ] final-literals ] unit-test @@ -323,6 +350,10 @@ TUPLE: mutable-tuple-test { x sequence } ; [ T{ mutable-tuple-test f "hey" } x>> ] final-classes ] unit-test +[ V{ tuple-layout } ] [ + [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes +] unit-test + ! Mixed mutable and immutable slots TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; @@ -332,3 +363,32 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; [ x>> ] [ y>> ] bi ] final-classes ] unit-test + +! Recursive propagation +: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive + +[ V{ null } ] [ [ recursive-test-1 ] final-classes ] unit-test + +: recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive + +[ V{ real } ] [ [ recursive-test-2 ] final-classes ] unit-test + +: recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive + +[ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test + +[ V{ real } ] [ [ [ dup 10 < ] [ ] [ ] while ] final-classes ] unit-test + +[ V{ float } ] [ + [ { float } declare 10 [ 2.3 * ] times ] final-classes +] unit-test + +: recursive-test-4 ( i n -- ) + 2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive + +[ ] [ [ recursive-test-4 ] final-info drop ] unit-test + +: recursive-test-5 ( a -- b ) + dup 2 > [ dup 1 - recursive-test-5 * ] when ; inline recursive + +[ V{ integer } ] [ [ recursive-test-5 ] final-info drop ] unit-test diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 731b0d06f7..1871717036 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors +USING: kernel sequences accessors arrays +stack-checker.inlining compiler.tree compiler.tree.propagation.info compiler.tree.propagation.nodes @@ -14,23 +15,48 @@ IN: compiler.tree.propagation.recursive ! We need to compute scalar evolution so that sccp doesn't ! evaluate loops -: (merge-value-infos) ( inputs -- infos ) +! row polymorphism is causing problems + +! infer-branch cloning and subsequent loss of state causing problems + +: merge-value-infos ( inputs -- infos ) [ [ value-info ] map value-infos-union ] map ; +USE: io +: compute-fixed-point ( label infos outputs -- ) + 2dup [ length ] bi@ = [ "Wrong length" throw ] unless + "compute-fixed-point" print USE: prettyprint + 2dup [ value-info ] map 2dup . . [ = ] 2all? [ 3drop ] [ + [ set-value-info ] 2each + f >>fixed-point drop + ] if ; -: 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 ; +: propagate-recursive-phi ( label #phi -- ) + "propagate-recursive-phi" print + [ [ phi-in-d>> merge-value-infos ] [ out-d>> ] bi compute-fixed-point ] + [ [ phi-in-r>> merge-value-infos ] [ out-r>> ] bi compute-fixed-point ] 2bi ; +USING: namespaces math ; +SYMBOL: iter-counter +0 iter-counter set-global M: #recursive propagate-around ( #recursive -- ) - dup - node-child - [ first>> (propagate) ] [ propagate-recursive-phi ] bi - [ drop ] [ propagate-around ] if ; + "#recursive" print + iter-counter inc + iter-counter get 10 > [ "Oops" throw ] when + [ label>> ] keep + [ node-child first>> propagate-recursive-phi ] + [ [ t >>fixed-point drop ] [ node-child first>> (propagate) ] bi* ] + [ swap fixed-point>> [ drop ] [ propagate-around ] if ] + 2tri ; USE: assocs M: #call-recursive propagate-before ( #call-label -- ) - [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ; + [ label>> ] [ label>> return>> [ value-info ] map ] [ out-d>> ] tri + dup [ dup value-infos get at [ drop ] [ object swap set-value-info ] if ] each + 2dup min-length [ tail* ] curry bi@ + compute-fixed-point ; + +M: #return propagate-before ( #return -- ) + "#return" print + dup label>> [ + [ label>> ] [ in-d>> [ value-info ] map ] [ in-d>> ] tri + compute-fixed-point + ] [ drop ] if ; diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index df10626967..663b0e12b8 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -39,15 +39,25 @@ UNION: fixed-length-sequence array byte-array string ; : tuple-constructor? ( node -- ? ) word>> { } memq? ; +: read-only-slots ( values class -- slots ) + #! Delegation. + all-slots rest-slice + [ read-only>> [ drop f ] unless ] 2map + { f f } prepend ; + +: fold- ( values class -- info ) + [ , f , [ literal>> ] map % ] { } make >tuple + ; + : propagate- ( node -- info ) #! Delegation in-d>> [ value-info ] map unclip-last - literal>> class>> dup immutable-tuple-class? [ - over [ literal?>> ] all? - [ [ , f , [ literal>> ] map % ] { } make >tuple ] - [ ] - if - ] [ nip ] if ; + literal>> class>> [ read-only-slots ] keep + over 2 tail-slice [ dup [ literal?>> ] when ] all? [ + [ 2 tail-slice ] dip fold- + ] [ + + ] if ; : propagate- ( node -- info ) in-d>> [ value-info ] map complex ; @@ -79,20 +89,29 @@ UNION: fixed-length-sequence array byte-array string ; [ [ class>> ] [ object ] if* class-or ] reduce ; +: tuple>array* ( tuple -- array ) + prepare-tuple>array + >r copy-tuple-slots r> + prefix ; + +: literal-info-slot ( slot info -- info' ) + { + { [ dup tuple? ] [ + tuple>array* nth + ] } + { [ dup complex? ] [ + [ real-part ] [ imaginary-part ] bi + 2array nth + ] } + } cond ; + : value-info-slot ( slot info -- info' ) #! Delegation. - [ class>> complex class<= 1 3 ? - ] keep - dup literal?>> [ - literal>> { - { [ dup tuple? ] [ - tuple-slots 1 tail-slice nth - ] } - { [ dup complex? ] [ - [ real-part ] [ imaginary-part ] bi - 2array nth - ] } - } cond - ] [ slots>> ?nth ] if ; + { + { [ over 0 = ] [ 2drop fixnum ] } + { [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] } + [ [ 1- ] [ slots>> ] bi* ?nth ] + } cond ; : reader-word-outputs ( node -- infos ) [ relevant-slots ] [ in-d>> first ] bi From 48e758814433a32e4ec3051222ed5dfe172c014f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 27 Jul 2008 00:10:01 -0500 Subject: [PATCH 03/65] opengl: Put top-left, top-right, bottom-left, bottom-right, in opengl.private --- extra/opengl/opengl.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 9e91119247..be70b1e176 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -195,6 +195,8 @@ TUPLE: sprite loc dim dim2 dlist texture ; : gl-translate ( point -- ) first2 0.0 glTranslated ; + + : four-sides ( dim -- ) dup top-left dup top-right dup bottom-right bottom-left ; From 96d7fd11dcad08cd62f307ea97d989d8e598fd45 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 27 Jul 2008 00:10:34 -0500 Subject: [PATCH 04/65] math.geometry.rect: Add corner words --- extra/math/geometry/rect/rect.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/extra/math/geometry/rect/rect.factor b/extra/math/geometry/rect/rect.factor index 4503d08a0a..7f0bb94092 100644 --- a/extra/math/geometry/rect/rect.factor +++ b/extra/math/geometry/rect/rect.factor @@ -1,5 +1,7 @@ -USING: kernel arrays sequences math.vectors math.geometry accessors ; +USING: kernel arrays sequences + math math.points math.vectors math.geometry + accessors ; IN: math.geometry.rect @@ -50,3 +52,10 @@ 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 ; + +! Accessing corners + +: top-left ( rect -- point ) loc>> ; +: top-right ( rect -- point ) [ loc>> ] [ width 1 - ] bi v+x ; +: bottom-left ( rect -- point ) [ loc>> ] [ height 1 - ] bi v+y ; +: bottom-right ( rect -- point ) [ loc>> ] [ dim>> ] bi v+ { 1 1 } v- ; From ed4a21262186badbac41e66d6e988caf4fd77abc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Jul 2008 02:32:20 -0500 Subject: [PATCH 05/65] Fix typo in docs --- core/sorting/sorting-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index 18bc7f14cf..036ff2f759 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -20,7 +20,7 @@ ABOUT: "sequences-sorting" HELP: sort { $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements into a new sequence of the same class as " { $snippet "seq" } "." } ; +{ $description "Sorts the elements into a new array." } ; HELP: sort-keys { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } From 863a6b63d5aafe7e36bf3fde8322f77530e81673 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Jul 2008 02:32:40 -0500 Subject: [PATCH 06/65] Working on recursive propagation --- .../tree/copy-equiv/copy-equiv.factor | 12 ++- .../compiler/tree/dead-code/dead-code.factor | 4 +- .../compiler/tree/def-use/def-use.factor | 12 ++- .../tree/propagation/info/info-tests.factor | 2 +- .../tree/propagation/info/info.factor | 16 +++- .../tree/propagation/nodes/nodes.factor | 1 + .../tree/propagation/propagation-tests.factor | 20 +++- .../propagation/recursive/recursive.factor | 96 ++++++++++++------- .../tree/propagation/slots/slots.factor | 2 +- unfinished/compiler/tree/tree.factor | 43 +++++---- .../compiler/tree/untupling/untupling.factor | 3 +- .../stack-checker/backend/backend.factor | 8 +- .../stack-checker/inlining/inlining.factor | 39 ++++---- .../transforms/transforms.factor | 6 +- .../stack-checker/visitor/dummy/dummy.factor | 8 +- .../stack-checker/visitor/visitor.factor | 8 +- 16 files changed, 173 insertions(+), 107 deletions(-) diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor index e3a2779376..2b7b6c5ecb 100644 --- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor +++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces disjoint-sets sequences assocs +USING: namespaces disjoint-sets sequences assocs math kernel accessors fry compiler.tree compiler.tree.def-use compiler.tree.combinators ; IN: compiler.tree.copy-equiv @@ -31,6 +31,16 @@ M: #r> compute-copy-equiv* M: #copy compute-copy-equiv* [ in-d>> ] [ out-d>> ] bi are-copies-of ; +M: #return-recursive compute-copy-equiv* + [ in-d>> ] [ out-d>> ] bi are-copies-of ; + +: unchanged-underneath ( #call-recursive -- n ) + [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ; + +M: #call-recursive compute-copy-equiv* + [ in-d>> ] [ out-d>> ] [ unchanged-underneath ] tri + '[ , head ] bi@ are-copies-of ; + M: node compute-copy-equiv* drop ; : compute-copy-equiv ( node -- node ) diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor index 365a0bdd45..fb5bc36dd7 100644 --- a/unfinished/compiler/tree/dead-code/dead-code.factor +++ b/unfinished/compiler/tree/dead-code/dead-code.factor @@ -21,9 +21,7 @@ M: #call mark-live-values [ 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 ; + look-at-inputs ; M: node mark-live-values drop ; diff --git a/unfinished/compiler/tree/def-use/def-use.factor b/unfinished/compiler/tree/def-use/def-use.factor index 51899c1dcf..d58a446030 100755 --- a/unfinished/compiler/tree/def-use/def-use.factor +++ b/unfinished/compiler/tree/def-use/def-use.factor @@ -52,12 +52,16 @@ M: node node-defs-values out-d>> ; [ dup node-uses-values [ use-value ] with each ] [ dup node-defs-values [ def-value ] with each ] bi ; +: check-def ( node -- ) + [ "No def" throw ] unless ; + +: check-use ( uses -- ) + [ empty? [ "No use" throw ] when ] + [ all-unique? [ "Uses not all unique" throw ] unless ] bi ; + : check-def-use ( -- ) def-use get [ - nip - [ node>> [ "No def" throw ] unless ] - [ uses>> all-unique? [ "Uses not all unique" throw ] unless ] - bi + nip [ node>> check-def ] [ uses>> check-use ] bi ] assoc-each ; : compute-def-use ( node -- node ) diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor index 64d32ce458..d7d4b509d3 100644 --- a/unfinished/compiler/tree/propagation/info/info-tests.factor +++ b/unfinished/compiler/tree/propagation/info/info-tests.factor @@ -59,7 +59,7 @@ IN: compiler.tree.propagation.info.tests [ 3 t ] [ 3 - null value-info-union >literal< + null-info value-info-union >literal< ] unit-test [ ] [ { } value-infos-union drop ] unit-test diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 6f78ba645e..8c76f9330c 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -27,6 +27,8 @@ literal? length slots ; +: null-info T{ value-info f null empty-interval } ; inline + : class-interval ( class -- interval ) dup real class<= [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ; @@ -200,15 +202,14 @@ DEFER: (value-info-union) : value-infos-union ( infos -- info ) dup empty? - [ drop null ] + [ drop null-info ] [ dup first [ value-info-union ] reduce ] if ; ! Current value --> info mapping SYMBOL: value-infos : value-info ( value -- info ) - resolve-copy value-infos get at - T{ value-info f null empty-interval } or ; + resolve-copy value-infos get at null-info or ; : set-value-info ( info value -- ) resolve-copy value-infos get set-at ; @@ -233,3 +234,12 @@ SYMBOL: value-infos : value-is? ( value class -- ? ) [ value-info class>> ] dip class<= ; + +: node-value-info ( node value -- info ) + swap info>> at* [ drop null-info ] unless ; + +: node-input-infos ( node -- seq ) + dup in-d>> [ node-value-info ] with map ; + +: node-output-infos ( node -- seq ) + dup out-d>> [ node-value-info ] with map ; diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor index 8da5b91f64..f4712f0d5d 100644 --- a/unfinished/compiler/tree/propagation/nodes/nodes.factor +++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor @@ -16,6 +16,7 @@ GENERIC: propagate-around ( node -- ) : (propagate) ( node -- ) [ + USING: classes prettyprint ; dup class . [ propagate-around ] [ successor>> ] bi (propagate) ] when* ; diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 659f9d6e76..531284b4fb 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -4,7 +4,8 @@ compiler.tree.def-use tools.test math math.order accessors sequences arrays kernel.private vectors alien.accessors alien.c-types sequences.private byte-arrays classes.algebra classes.tuple.private -math.functions math.private strings layouts ; +math.functions math.private strings layouts +compiler.tree.propagation.info ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -383,12 +384,25 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; [ { float } declare 10 [ 2.3 * ] times ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ 0 10 [ nip ] each-integer ] final-classes +] unit-test + +[ V{ t } ] [ + [ t 10 [ nip 0 >= ] each-integer ] final-literals +] unit-test + : recursive-test-4 ( i n -- ) 2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive [ ] [ [ recursive-test-4 ] final-info drop ] unit-test : recursive-test-5 ( a -- b ) - dup 2 > [ dup 1 - recursive-test-5 * ] when ; inline recursive + dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-5 * ] if ; inline recursive -[ V{ integer } ] [ [ recursive-test-5 ] final-info drop ] unit-test +[ V{ integer } ] [ [ { integer } declare recursive-test-5 ] final-classes ] unit-test + +: recursive-test-6 ( a -- b ) + dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-6 swap 2 - recursive-test-6 + ] if ; inline recursive + +[ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 1871717036..f5755d77b2 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors arrays +USING: kernel sequences accessors arrays fry math.intervals +combinators stack-checker.inlining compiler.tree compiler.tree.propagation.info @@ -9,54 +10,75 @@ compiler.tree.propagation.simple compiler.tree.propagation.branches ; IN: compiler.tree.propagation.recursive -! 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 - ! row polymorphism is causing problems -! infer-branch cloning and subsequent loss of state causing problems +: longest-suffix ( seq1 seq2 -- seq1' seq2' ) + 2dup min-length [ tail-slice* ] curry bi@ ; -: merge-value-infos ( inputs -- infos ) - [ [ value-info ] map value-infos-union ] map ; -USE: io -: compute-fixed-point ( label infos outputs -- ) - 2dup [ length ] bi@ = [ "Wrong length" throw ] unless - "compute-fixed-point" print USE: prettyprint - 2dup [ value-info ] map 2dup . . [ = ] 2all? [ 3drop ] [ - [ set-value-info ] 2each - f >>fixed-point drop +: suffixes= ( seq1 seq2 -- ? ) + longest-suffix sequence= ; + +: check-fixed-point ( node infos1 infos2 -- node ) + suffixes= [ dup label>> f >>fixed-point drop ] unless ; inline + +: recursive-stacks ( #enter-recursive -- stacks initial ) + [ label>> calls>> [ node-input-infos ] map ] + [ in-d>> [ value-info ] map ] bi + [ length '[ , tail* ] map flip ] keep ; + +: generalize-counter-interval ( i1 i2 -- i3 ) + { + { [ 2dup interval<= ] [ 1./0. [a,a] ] } + { [ 2dup interval>= ] [ -1./0. [a,a] ] } + [ [-inf,inf] ] + } cond nip interval-union ; + +: generalize-counter ( info' initial -- info ) + [ drop clone ] [ [ interval>> ] bi@ ] 2bi + generalize-counter-interval >>interval + f >>literal? f >>literal ; + +: unify-recursive-stacks ( stacks initial -- infos ) + over empty? [ nip ] [ + [ + [ sift value-infos-union ] dip + [ generalize-counter ] keep + value-info-union + ] 2map ] if ; -: propagate-recursive-phi ( label #phi -- ) - "propagate-recursive-phi" print - [ [ phi-in-d>> merge-value-infos ] [ out-d>> ] bi compute-fixed-point ] - [ [ phi-in-r>> merge-value-infos ] [ out-r>> ] bi compute-fixed-point ] 2bi ; +: propagate-recursive-phi ( #enter-recursive -- ) + [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri + [ node-output-infos check-fixed-point drop ] 2keep + out-d>> set-value-infos ; USING: namespaces math ; SYMBOL: iter-counter 0 iter-counter set-global M: #recursive propagate-around ( #recursive -- ) - "#recursive" print iter-counter inc iter-counter get 10 > [ "Oops" throw ] when - [ label>> ] keep - [ node-child first>> propagate-recursive-phi ] - [ [ t >>fixed-point drop ] [ node-child first>> (propagate) ] bi* ] - [ swap fixed-point>> [ drop ] [ propagate-around ] if ] - 2tri ; USE: assocs + dup label>> t >>fixed-point drop + [ node-child first>> [ propagate-recursive-phi ] [ (propagate) ] bi ] + [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] + bi ; + +: generalize-return-interval ( info -- info' ) + dup literal?>> [ + clone [-inf,inf] >>interval + ] unless ; + +: generalize-return ( infos -- infos' ) + [ generalize-return-interval ] map ; M: #call-recursive propagate-before ( #call-label -- ) - [ label>> ] [ label>> return>> [ value-info ] map ] [ out-d>> ] tri - dup [ dup value-infos get at [ drop ] [ object swap set-value-info ] if ] each - 2dup min-length [ tail* ] curry bi@ - compute-fixed-point ; + dup + [ node-output-infos ] + [ label>> return>> node-input-infos ] + bi check-fixed-point + [ label>> return>> node-input-infos generalize-return ] [ out-d>> ] bi + longest-suffix set-value-infos ; -M: #return propagate-before ( #return -- ) - "#return" print - dup label>> [ - [ label>> ] [ in-d>> [ value-info ] map ] [ in-d>> ] tri - compute-fixed-point - ] [ drop ] if ; +M: #return-recursive propagate-before ( #return-recursive -- ) + dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi + check-fixed-point drop ; diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index 663b0e12b8..c0a445d237 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -77,7 +77,7 @@ UNION: fixed-length-sequence array byte-array string ; relevant-methods [ nip "reading" word-prop ] { } assoc>map ; : no-reader-methods ( input slots -- info ) - 2drop null ; + 2drop null-info ; : same-offset ( slots -- slot/f ) dup [ dup [ read-only>> ] when ] all? [ diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor index 5d15fc9185..9a41181726 100755 --- a/unfinished/compiler/tree/tree.factor +++ b/unfinished/compiler/tree/tree.factor @@ -35,15 +35,6 @@ M: node hashcode* drop node hashcode* ; 2drop f ] if ; -: node-value-info ( node value -- info ) - swap info>> at ; - -: node-input-infos ( node -- seq ) - dup in-d>> [ node-value-info ] with map ; - -: node-output-infos ( node -- seq ) - dup out-d>> [ node-value-info ] with map ; - TUPLE: #introduce < node values ; : #introduce ( values -- node ) @@ -99,7 +90,9 @@ TUPLE: #r> < node ; TUPLE: #terminate < node ; -: #terminate ( -- node ) \ #terminate new ; +: #terminate ( stack -- node ) + \ #terminate new + swap >>in-d ; TUPLE: #branch < node ; @@ -133,23 +126,37 @@ TUPLE: #declare < node declaration ; \ #declare new swap >>declaration ; -TUPLE: #return < node label ; +TUPLE: #return < node ; -: #return ( label stack -- node ) +: #return ( stack -- node ) \ #return new - swap >>in-d - swap >>label ; + swap >>in-d ; TUPLE: #recursive < node word label loop? returns calls ; -: #recursive ( word label inputs outputs child -- node ) +: #recursive ( word label inputs child -- node ) \ #recursive new swap 1array >>children - swap >>out-d swap >>in-d swap >>label swap >>word ; +TUPLE: #enter-recursive < node label ; + +: #enter-recursive ( label inputs outputs -- node ) + \ #enter-recursive new + swap >>out-d + swap >>in-d + swap >>label ; + +TUPLE: #return-recursive < node label ; + +: #return-recursive ( label inputs outputs -- node ) + \ #return-recursive new + swap >>out-d + swap >>in-d + swap >>label ; + TUPLE: #copy < node ; : #copy ( inputs outputs -- node ) @@ -175,13 +182,15 @@ TUPLE: node-list first last ; 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 #enter-recursive, #enter-recursive node, ; +M: node-list #return-recursive, #return-recursive [ node, ] [ dup label>> (>>return) ] bi ; +M: node-list #call-recursive, #call-recursive [ node, ] [ dup label>> calls>> push ] bi ; M: node-list #terminate, #terminate node, ; M: node-list #if, #if node, ; M: node-list #dispatch, #dispatch node, ; diff --git a/unfinished/compiler/tree/untupling/untupling.factor b/unfinished/compiler/tree/untupling/untupling.factor index 6fb51e3fa1..ebc43ece08 100644 --- a/unfinished/compiler/tree/untupling/untupling.factor +++ b/unfinished/compiler/tree/untupling/untupling.factor @@ -29,8 +29,7 @@ M: #call compute-untupling* [ drop mark-escaping-values ] } case ; -M: #return compute-untupling* - dup label>> [ drop ] [ mark-escaping-values ] if ; +M: #return compute-untupling* mark-escaping-values ; M: node compute-untupling* drop ; diff --git a/unfinished/stack-checker/backend/backend.factor b/unfinished/stack-checker/backend/backend.factor index 900980c0ea..2977f2520a 100755 --- a/unfinished/stack-checker/backend/backend.factor +++ b/unfinished/stack-checker/backend/backend.factor @@ -82,7 +82,7 @@ M: wrapper apply-object M: object apply-object push-literal ; : terminate ( -- ) - terminated? on #terminate, ; + terminated? on meta-d get clone #terminate, ; : infer-quot ( quot rstate -- ) recursive-state get [ @@ -113,10 +113,10 @@ M: object apply-object push-literal ; ] if ; : infer->r ( n -- ) - consume-d [ dup copy-values #>r, ] [ output-r ] bi ; + consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ; : infer-r> ( n -- ) - consume-r [ dup copy-values #r>, ] [ output-d ] bi ; + consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ; : undo-infer ( -- ) recorded get [ f +inferred-effect+ set-word-prop ] each ; @@ -140,7 +140,7 @@ M: object apply-object push-literal ; : end-infer ( -- ) check->r - f meta-d get clone #return, ; + meta-d get clone #return, ; : effect-required? ( word -- ? ) { diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor index 7c24ddf9ea..5dc159bcc4 100644 --- a/unfinished/stack-checker/inlining/inlining.factor +++ b/unfinished/stack-checker/inlining/inlining.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces assocs kernel sequences words accessors definitions math effects classes arrays combinators vectors +arrays stack-checker.state stack-checker.visitor stack-checker.backend @@ -16,12 +17,12 @@ IN: stack-checker.inlining : (inline-word) ( word label -- ) [ [ def>> ] keep ] dip infer-quot-recursive ; -TUPLE: inline-recursive word phi-in phi-out returns ; +TUPLE: inline-recursive word enter-out return calls fixed-point ; : ( word -- label ) inline-recursive new swap >>word - V{ } clone >>returns ; + V{ } clone >>calls ; : quotation-param? ( obj -- ? ) dup pair? [ second effect? ] [ drop f ] if ; @@ -29,23 +30,20 @@ TUPLE: inline-recursive word phi-in phi-out returns ; : make-copies ( values effect-in -- values' ) [ quotation-param? [ copy-value ] [ drop ] if ] 2map ; -SYMBOL: phi-in -SYMBOL: phi-out +SYMBOL: enter-in +SYMBOL: enter-out : prepare-stack ( word -- ) required-stack-effect in>> [ length ensure-d ] keep - [ drop 1vector phi-in set ] - [ make-copies phi-out set ] - 2bi ; + [ drop enter-in set ] [ make-copies enter-out set ] 2bi ; -: emit-phi-function ( label -- ) - phi-in get >>phi-in - phi-out get >>phi-out drop - phi-in get phi-out get { { } } { } #phi, - phi-out get >vector meta-d set ; +: emit-enter-recursive ( label -- ) + enter-out get >>enter-out + enter-in get enter-out get #enter-recursive, + enter-out get >vector meta-d set ; : entry-stack-height ( label -- stack ) - phi-out>> length ; + enter-out>> length ; : check-return ( word label -- ) 2dup @@ -59,7 +57,7 @@ SYMBOL: phi-out : end-recursive-word ( word label -- ) [ check-return ] - [ meta-d get [ #return, ] [ swap returns>> push ] 2bi ] + [ meta-d get dup copy-values dup meta-d set #return-recursive, ] bi ; : recursive-word-inputs ( label -- n ) @@ -72,7 +70,7 @@ SYMBOL: phi-out nest-visitor dup - [ dup emit-phi-function (inline-word) ] + [ dup emit-enter-recursive (inline-word) ] [ end-recursive-word ] [ ] 2tri @@ -86,7 +84,7 @@ SYMBOL: phi-out : inline-recursive-word ( word -- ) (inline-recursive-word) - [ consume-d ] [ dup output-d ] [ ] tri* #recursive, ; + [ consume-d ] [ output-d ] [ ] tri* #recursive, ; : check-call-height ( word label -- ) entry-stack-height current-stack-height > @@ -96,18 +94,13 @@ SYMBOL: phi-out required-stack-effect in>> length meta-d get swap tail* ; : check-call-site-stack ( stack label -- ) - tuck phi-out>> + tuck enter-out>> [ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all? [ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ; : add-call ( word label -- ) [ check-call-height ] - [ - [ call-site-stack ] dip - [ check-call-site-stack ] - [ phi-in>> swap [ suffix ] 2change-each ] - 2bi - ] 2bi ; + [ [ call-site-stack ] dip check-call-site-stack ] 2bi ; : adjust-stack-effect ( effect -- effect' ) [ in>> ] [ out>> ] bi diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor index 8b0f903074..5ec3f5ad64 100755 --- a/unfinished/stack-checker/transforms/transforms.factor +++ b/unfinished/stack-checker/transforms/transforms.factor @@ -4,7 +4,8 @@ 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 continuations -stack-checker.backend stack-checker.state stack-checker.errors ; +stack-checker.backend stack-checker.state stack-checker.visitor +stack-checker.errors ; IN: stack-checker.transforms SYMBOL: +transform-quot+ @@ -15,8 +16,9 @@ SYMBOL: +transform-n+ drop recursive-state get 1array ] [ consume-d + [ #drop, ] [ [ literal value>> ] map ] - [ first literal recursion>> ] bi prefix + [ first literal recursion>> ] tri prefix ] if swap with-datastack ; diff --git a/unfinished/stack-checker/visitor/dummy/dummy.factor b/unfinished/stack-checker/visitor/dummy/dummy.factor index dc20d6acb1..7ab13fdd47 100644 --- a/unfinished/stack-checker/visitor/dummy/dummy.factor +++ b/unfinished/stack-checker/visitor/dummy/dummy.factor @@ -11,12 +11,14 @@ M: f #push, 2drop ; M: f #shuffle, 3drop ; M: f #>r, 2drop ; M: f #r>, 2drop ; -M: f #return, 2drop ; -M: f #terminate, ; +M: f #return, drop ; +M: f #enter-recursive, 3drop ; +M: f #return-recursive, 3drop ; +M: f #terminate, drop ; M: f #if, 3drop ; M: f #dispatch, 2drop ; M: f #phi, 2drop 2drop ; M: f #declare, drop ; -M: f #recursive, drop drop drop drop drop ; +M: f #recursive, 2drop 2drop ; M: f #copy, 2drop ; M: f #drop, drop ; diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor index de9fa947c7..231b0ab9bf 100644 --- a/unfinished/stack-checker/visitor/visitor.factor +++ b/unfinished/stack-checker/visitor/visitor.factor @@ -17,11 +17,13 @@ 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: #terminate, stack-visitor ( stack -- ) 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: #return, stack-visitor ( stack -- ) +HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- ) +HOOK: #return-recursive, stack-visitor ( label inputs outputs -- ) +HOOK: #recursive, stack-visitor ( word label inputs visitor -- ) HOOK: #copy, stack-visitor ( inputs outputs -- ) From 74197538f560c660b1b888d4f834ae415ed36237 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Jul 2008 20:25:42 -0500 Subject: [PATCH 07/65] Change high-level IR to not use 'successor' links; add normalization pass --- .../tree/branch-fusion/branch-fusion.factor | 5 + .../compiler/tree/builder/builder.factor | 12 +- .../compiler/tree/cleanup/cleanup.factor | 5 + .../tree/combinators/combinators-tests.factor | 15 +-- .../tree/combinators/combinators.factor | 73 ++--------- .../backward/backward.factor | 4 +- .../dataflow-analysis.factor} | 2 +- .../compiler/tree/dead-code/dead-code.factor | 4 +- .../compiler/tree/def-use/def-use.factor | 48 +++---- .../tree/loop-detection/loop-detection.factor | 5 + .../normalization/normalization-tests.factor | 27 ++++ .../tree/normalization/normalization.factor | 94 ++++++++++++++ .../compiler/tree/optimizer/optimizer.factor | 21 ++++ .../tree/propagation/branches/branches.factor | 21 ++-- .../tree/propagation/inlining/inlining.factor | 3 + .../tree/propagation/nodes/nodes.factor | 7 +- .../tree/propagation/propagation-tests.factor | 6 +- .../propagation/recursive/recursive.factor | 2 +- .../tree/propagation/simple/simple.factor | 2 +- .../strength-reduction.factor | 5 + unfinished/compiler/tree/tree.factor | 117 ++++++------------ .../compiler/tree/untupling/untupling.factor | 3 +- .../stack-checker/backend/backend.factor | 7 +- .../stack-checker/visitor/visitor.factor | 2 +- 24 files changed, 280 insertions(+), 210 deletions(-) create mode 100644 unfinished/compiler/tree/branch-fusion/branch-fusion.factor create mode 100644 unfinished/compiler/tree/cleanup/cleanup.factor rename unfinished/compiler/tree/{dfa => dataflow-analysis}/backward/backward.factor (94%) rename unfinished/compiler/tree/{dfa/dfa.factor => dataflow-analysis/dataflow-analysis.factor} (96%) create mode 100644 unfinished/compiler/tree/loop-detection/loop-detection.factor create mode 100644 unfinished/compiler/tree/normalization/normalization-tests.factor create mode 100644 unfinished/compiler/tree/normalization/normalization.factor create mode 100644 unfinished/compiler/tree/optimizer/optimizer.factor create mode 100644 unfinished/compiler/tree/propagation/inlining/inlining.factor create mode 100644 unfinished/compiler/tree/strength-reduction/strength-reduction.factor diff --git a/unfinished/compiler/tree/branch-fusion/branch-fusion.factor b/unfinished/compiler/tree/branch-fusion/branch-fusion.factor new file mode 100644 index 0000000000..b1078c85fb --- /dev/null +++ b/unfinished/compiler/tree/branch-fusion/branch-fusion.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.tree.branch-fusion + +: fuse-branches ( nodes -- nodes' ) ; diff --git a/unfinished/compiler/tree/builder/builder.factor b/unfinished/compiler/tree/builder/builder.factor index 79a2786f64..c390658597 100644 --- a/unfinished/compiler/tree/builder/builder.factor +++ b/unfinished/compiler/tree/builder/builder.factor @@ -7,11 +7,11 @@ stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.backend compiler.tree ; IN: compiler.tree.builder -: with-tree-builder ( quot -- dataflow ) - [ node-list new stack-visitor set ] prepose - with-infer first>> ; inline +: with-tree-builder ( quot -- nodes ) + [ V{ } clone stack-visitor set ] prepose + with-infer ; inline -GENERIC# build-tree-with 1 ( quot stack -- dataflow ) +GENERIC# build-tree-with 1 ( quot stack -- nodes ) M: callable build-tree-with #! Not safe to call from inference transforms. @@ -20,7 +20,7 @@ M: callable build-tree-with f infer-quot ] with-tree-builder nip ; -: build-tree ( quot -- dataflow ) f build-tree-with ; +: build-tree ( quot -- nodes ) f build-tree-with ; : (make-specializer) ( class picker -- quot ) swap "predicate" word-prop append ; @@ -65,7 +65,7 @@ M: callable build-tree-with [ drop ] } cond ; -: build-tree-from-word ( word -- effect dataflow ) +: build-tree-from-word ( word -- effect nodes ) [ [ dup +cannot-infer+ word-prop [ cannot-infer-effect ] when diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor new file mode 100644 index 0000000000..725d6c0abe --- /dev/null +++ b/unfinished/compiler/tree/cleanup/cleanup.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.tree.cleanup + +: cleanup ( nodes -- nodes' ) ; diff --git a/unfinished/compiler/tree/combinators/combinators-tests.factor b/unfinished/compiler/tree/combinators/combinators-tests.factor index 15c07635ad..12ab7e3563 100644 --- a/unfinished/compiler/tree/combinators/combinators-tests.factor +++ b/unfinished/compiler/tree/combinators/combinators-tests.factor @@ -1,17 +1,4 @@ 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 +USING: compiler.tree.combinators tools.test kernel ; { 1 0 } [ [ drop ] each-node ] must-infer-as - -{ 1 0 } [ [ ] map-children ] must-infer-as diff --git a/unfinished/compiler/tree/combinators/combinators.factor b/unfinished/compiler/tree/combinators/combinators.factor index 1f626163e5..94bcdb2d95 100644 --- a/unfinished/compiler/tree/combinators/combinators.factor +++ b/unfinished/compiler/tree/combinators/combinators.factor @@ -1,64 +1,17 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry arrays generic assocs kernel math namespaces parser -sequences words vectors math.intervals effects classes -accessors combinators compiler.tree ; +USING: fry kernel accessors sequences compiler.tree ; IN: compiler.tree.combinators -SYMBOL: node-stack - -: >node ( node -- ) node-stack get push ; -: node> ( -- node ) node-stack get pop ; -: node@ ( -- node ) node-stack get peek ; - -: iterate-next ( -- node ) node@ successor>> ; - -: iterate-nodes ( node quot -- ) - over [ - [ swap >node call node> drop ] keep iterate-nodes - ] [ - 2drop - ] if ; inline - -: (each-node) ( quot -- next ) - node@ [ swap call ] 2keep - children>> [ - first>> [ - [ (each-node) ] keep swap - ] iterate-nodes - ] each drop - iterate-next ; inline - -: with-node-iterator ( quot -- ) - >r V{ } clone node-stack r> with-variable ; inline - -: each-node ( node quot -- ) - [ - swap [ - [ (each-node) ] keep swap - ] iterate-nodes drop - ] with-node-iterator ; inline - -: map-children ( node quot -- ) - [ children>> ] dip '[ , change-first drop ] each ; inline - -: (transform-nodes) ( prev node quot -- ) - dup >r call dup [ - >>successor - successor>> dup successor>> - r> (transform-nodes) - ] [ - r> 2drop f >>successor drop - ] if ; inline - -: transform-nodes ( node quot -- new-node ) - over [ - [ call dup dup successor>> ] keep (transform-nodes) - ] [ drop ] if ; inline - -: tail-call? ( -- ? ) - #! We don't consider calls which do non-local exits to be - #! tail calls, because this gives better error traces. - node-stack get [ - successor>> [ #tail? ] [ #terminate? not ] bi and - ] all? ; +: each-node ( nodes quot -- ) + dup dup '[ + , [ + dup #branch? [ + children>> [ , each-node ] each + ] [ + dup #recursive? [ + child>> , each-node + ] [ drop ] if + ] if + ] bi + ] each ; inline diff --git a/unfinished/compiler/tree/dfa/backward/backward.factor b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor similarity index 94% rename from unfinished/compiler/tree/dfa/backward/backward.factor rename to unfinished/compiler/tree/dataflow-analysis/backward/backward.factor index cb2b13e6bb..c9caeb864b 100644 --- a/unfinished/compiler/tree/dfa/backward/backward.factor +++ b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: compiler.tree.dfa.backward +IN: compiler.tree.dataflow-analysis.backward USING: accessors sequences assocs kernel compiler.tree -compiler.tree.dfa ; +compiler.tree.dataflow-analysis ; GENERIC: backward ( value node -- ) diff --git a/unfinished/compiler/tree/dfa/dfa.factor b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor similarity index 96% rename from unfinished/compiler/tree/dfa/dfa.factor rename to unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor index 3a7770c53f..b6772650b6 100644 --- a/unfinished/compiler/tree/dfa/dfa.factor +++ b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor @@ -3,7 +3,7 @@ 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 +IN: compiler.tree.dataflow-analysis ! Dataflow analysis SYMBOL: work-list diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor index fb5bc36dd7..ccf8a9cd09 100644 --- a/unfinished/compiler/tree/dead-code/dead-code.factor +++ b/unfinished/compiler/tree/dead-code/dead-code.factor @@ -3,8 +3,8 @@ USING: fry accessors namespaces assocs dequeues search-dequeues kernel sequences words sets stack-checker.inlining compiler.tree -compiler.tree.dfa -compiler.tree.dfa.backward +compiler.tree.dataflow-analysis +compiler.tree.dataflow-analysis.backward compiler.tree.combinators ; IN: compiler.tree.dead-code diff --git a/unfinished/compiler/tree/def-use/def-use.factor b/unfinished/compiler/tree/def-use/def-use.factor index d58a446030..189dd292a2 100755 --- a/unfinished/compiler/tree/def-use/def-use.factor +++ b/unfinished/compiler/tree/def-use/def-use.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs sequences kernel generic assocs classes -vectors accessors combinators sets stack-checker.state +USING: arrays namespaces assocs sequences kernel generic assocs +classes vectors accessors combinators sets stack-checker.state compiler.tree compiler.tree.combinators ; IN: compiler.tree.def-use @@ -9,60 +9,60 @@ SYMBOL: def-use TUPLE: definition value node uses ; -: ( value -- definition ) +: ( node value -- definition ) definition new swap >>value + swap >>node V{ } clone >>uses ; : def-of ( value -- definition ) - def-use get [ ] cache ; + def-use get at* [ "No def" throw ] unless ; : def-value ( node value -- ) - def-of [ [ "Multiple defs" throw ] when ] change-node drop ; + def-use get 2dup key? [ + "Multiple defs" throw + ] [ + [ [ ] keep ] dip set-at + ] if ; : used-by ( value -- nodes ) def-of uses>> ; : use-value ( node value -- ) used-by push ; -: defined-by ( value -- node ) def-use get at node>> ; +: defined-by ( value -- node ) def-of node>> ; 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 sift prune ; - +M: #introduce node-uses-values drop f ; +M: #push node-uses-values drop f ; M: #r> node-uses-values in-r>> ; - +M: #phi node-uses-values + [ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ; +M: #declare node-uses-values declaration>> keys ; M: node node-uses-values in-d>> ; GENERIC: node-defs-values ( node -- values ) -M: #introduce node-defs-values values>> ; - +M: #introduce node-defs-values value>> 1array ; M: #>r node-defs-values out-r>> ; - +M: #branch node-defs-values drop f ; M: #phi node-defs-values [ out-d>> ] [ out-r>> ] bi append ; - +M: #declare node-defs-values drop f ; +M: #return node-defs-values drop f ; +M: #recursive node-defs-values drop f ; +M: #terminate node-defs-values drop f ; M: node node-defs-values out-d>> ; : node-def-use ( node -- ) [ dup node-uses-values [ use-value ] with each ] [ dup node-defs-values [ def-value ] with each ] bi ; -: check-def ( node -- ) - [ "No def" throw ] unless ; - : check-use ( uses -- ) [ empty? [ "No use" throw ] when ] [ all-unique? [ "Uses not all unique" throw ] unless ] bi ; : check-def-use ( -- ) - def-use get [ - nip [ node>> check-def ] [ uses>> check-use ] bi - ] assoc-each ; + def-use get [ nip uses>> check-use ] assoc-each ; : compute-def-use ( node -- node ) H{ } clone def-use set diff --git a/unfinished/compiler/tree/loop-detection/loop-detection.factor b/unfinished/compiler/tree/loop-detection/loop-detection.factor new file mode 100644 index 0000000000..e29ae22f0d --- /dev/null +++ b/unfinished/compiler/tree/loop-detection/loop-detection.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.tree.loop-detection + +: detect-loops ( nodes -- nodes' ) ; diff --git a/unfinished/compiler/tree/normalization/normalization-tests.factor b/unfinished/compiler/tree/normalization/normalization-tests.factor new file mode 100644 index 0000000000..39a71ad0a6 --- /dev/null +++ b/unfinished/compiler/tree/normalization/normalization-tests.factor @@ -0,0 +1,27 @@ +IN: compiler.tree.normalization.tests +USING: compiler.tree.builder compiler.tree.normalization +compiler.tree sequences accessors tools.test kernel ; + +\ collect-introductions must-infer +\ fixup-enter-recursive must-infer +\ eliminate-introductions must-infer +\ normalize must-infer + +[ 3 ] [ [ 3drop 1 2 3 ] build-tree collect-introductions ] unit-test + +[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree collect-introductions ] unit-test + +[ 3 ] [ [ [ drop ] [ 2drop 3 ] if ] build-tree collect-introductions ] unit-test + +[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree collect-introductions ] unit-test + +: foo ( -- ) swap ; inline recursive + +: recursive-inputs ( nodes -- n ) + [ #recursive? ] find nip child>> first in-d>> length ; + +[ 0 2 ] [ + [ foo ] build-tree + [ recursive-inputs ] + [ normalize recursive-inputs ] bi +] unit-test diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor new file mode 100644 index 0000000000..38fa3e11b3 --- /dev/null +++ b/unfinished/compiler/tree/normalization/normalization.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces sequences math accessors kernel arrays +stack-checker.backend compiler.tree compiler.tree.combinators ; +IN: compiler.tree.normalization + +! A transform pass done before optimization can begin to +! fix up some oddities in the tree output by the stack checker: +! +! - We rewrite the code is that #introduce nodes only appear +! at the top level, and not inside #recursive. This enables more +! accurate type inference for 'row polymorphic' combinators. +! +! - We collect #return-recursive and #call-recursive nodes and +! store them in the #recursive's label slot. + +GENERIC: normalize* ( node -- ) + +! Collect introductions +SYMBOL: introductions + +GENERIC: collect-introductions* ( node -- ) + +: collect-introductions ( nodes -- n ) + [ + 0 introductions set + [ collect-introductions* ] each + introductions get + ] with-scope ; + +M: #introduce collect-introductions* drop introductions inc ; + +M: #branch collect-introductions* + children>> + [ collect-introductions ] map supremum + introductions [ + ] change ; + +M: node collect-introductions* drop ; + +! Eliminate introductions +SYMBOL: introduction-stack + +: fixup-enter-recursive ( recursive -- ) + [ child>> first ] [ in-d>> ] bi >>in-d + [ introduction-stack get prepend ] change-out-d + drop ; + +GENERIC: eliminate-introductions* ( node -- node' ) + +: pop-introduction ( -- value ) + introduction-stack [ unclip-last swap ] change ; + +M: #introduce eliminate-introductions* + pop-introduction swap value>> [ 1array ] bi@ #copy ; + +SYMBOL: remaining-introductions + +M: #branch eliminate-introductions* + dup children>> [ + [ + [ eliminate-introductions* ] change-each + introduction-stack get + ] with-scope + ] map + [ remaining-introductions set ] + [ [ length ] map infimum introduction-stack [ swap head ] change ] + bi ; + +M: #phi eliminate-introductions* + remaining-introductions get swap + [ flip [ over length tail append ] 2map flip ] change-phi-in-d ; + +M: node eliminate-introductions* ; + +: eliminate-introductions ( recursive n -- ) + make-values introduction-stack set + [ fixup-enter-recursive ] + [ child>> [ eliminate-introductions* ] change-each ] bi ; + +M: #recursive normalize* + [ + [ child>> collect-introductions ] + [ swap eliminate-introductions ] + bi + ] with-scope ; + +! Collect label info +M: #return-recursive normalize* dup label>> (>>return) ; + +M: #call-recursive normalize* dup label>> calls>> push ; + +M: node normalize* drop ; + +: normalize ( node -- node ) dup [ normalize* ] each-node ; diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor new file mode 100644 index 0000000000..bb33deb7e7 --- /dev/null +++ b/unfinished/compiler/tree/optimizer/optimizer.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: compiler.tree.normalization compiler.tree.copy-equiv +compiler.tree.propagation compiler.tree.cleanup +compiler.tree.def-use compiler.tree.untupling +compiler.tree.dead-code compiler.tree.strength-reduction +compiler.tree.loop-detection compiler.tree.branch-fusion ; +IN: compiler.tree.optimizer + +: optimize-tree ( nodes -- nodes' ) + normalize + compute-copy-equiv + propagate + cleanup + compute-def-use + unbox-tuples + compute-def-use + remove-dead-code + strength-reduce + detect-loops + fuse-branches ; diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index 22f0978e22..a8b623eb51 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/unfinished/compiler/tree/propagation/branches/branches.factor @@ -31,21 +31,23 @@ M: #dispatch live-children [ children>> ] [ in-d>> first value-info interval>> ] bi '[ , interval-contains? [ drop f ] unless ] map-index ; -: infer-children ( node -- assocs ) +SYMBOL: infer-children-data + +: infer-children ( node -- ) [ live-children ] [ child-constraints ] bi [ [ over [ value-infos [ clone ] change constraints [ clone ] change assume - first>> (propagate) + (propagate) ] [ 2drop value-infos off constraints off ] if ] H{ } make-assoc - ] 2map ; + ] 2map infer-children-data set ; : (merge-value-infos) ( inputs results -- infos ) '[ , [ [ value-info ] bind ] 2map value-infos-union ] map ; @@ -53,7 +55,8 @@ M: #dispatch live-children : merge-value-infos ( results inputs outputs -- ) [ swap (merge-value-infos) ] dip set-value-infos ; -: propagate-branch-phi ( results #phi -- ) +M: #phi propagate-before ( #phi -- ) + infer-children-data get swap [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ] [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ] 2bi ; @@ -67,10 +70,10 @@ M: #dispatch live-children ] [ 3drop ] if ] 2each ; -: merge-children ( results node -- ) - [ successor>> propagate-branch-phi ] - [ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ] - bi ; +! : merge-children +! [ 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 ; + [ infer-children ] [ annotate-node ] bi ; diff --git a/unfinished/compiler/tree/propagation/inlining/inlining.factor b/unfinished/compiler/tree/propagation/inlining/inlining.factor new file mode 100644 index 0000000000..a33ef00c34 --- /dev/null +++ b/unfinished/compiler/tree/propagation/inlining/inlining.factor @@ -0,0 +1,3 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.tree.propagation.inlining diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor index f4712f0d5d..2cc98b28c6 100644 --- a/unfinished/compiler/tree/propagation/nodes/nodes.factor +++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor @@ -14,9 +14,4 @@ GENERIC: propagate-after ( node -- ) GENERIC: propagate-around ( node -- ) -: (propagate) ( node -- ) - [ - USING: classes prettyprint ; dup class . - [ propagate-around ] [ successor>> ] bi - (propagate) - ] when* ; +: (propagate) ( node -- ) [ [ propagate-around ] each ] when* ; diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 531284b4fb..f15927c8f4 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -1,6 +1,6 @@ USING: kernel compiler.tree.builder compiler.tree compiler.tree.propagation compiler.tree.copy-equiv -compiler.tree.def-use tools.test math math.order +compiler.tree.normalization tools.test math math.order accessors sequences arrays kernel.private vectors alien.accessors alien.c-types sequences.private byte-arrays classes.algebra classes.tuple.private @@ -13,10 +13,10 @@ IN: compiler.tree.propagation.tests : final-info ( quot -- seq ) build-tree - compute-def-use + normalize compute-copy-equiv propagate - last-node node-input-infos ; + peek node-input-infos ; : final-classes ( quot -- seq ) final-info [ class>> ] map ; diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index f5755d77b2..e1905d5b44 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -59,7 +59,7 @@ M: #recursive propagate-around ( #recursive -- ) iter-counter inc iter-counter get 10 > [ "Oops" throw ] when dup label>> t >>fixed-point drop - [ node-child first>> [ propagate-recursive-phi ] [ (propagate) ] bi ] + [ child>> [ first propagate-recursive-phi ] [ (propagate) ] bi ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ; diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index 10beb6f6e0..42468dff8d 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/unfinished/compiler/tree/propagation/simple/simple.factor @@ -13,7 +13,7 @@ compiler.tree.propagation.constraints ; IN: compiler.tree.propagation.simple M: #introduce propagate-before - object swap values>> [ set-value-info ] with each ; + value>> object swap set-value-info ; M: #push propagate-before [ literal>> value>> ] [ out-d>> first ] bi diff --git a/unfinished/compiler/tree/strength-reduction/strength-reduction.factor b/unfinished/compiler/tree/strength-reduction/strength-reduction.factor new file mode 100644 index 0000000000..c36395bbee --- /dev/null +++ b/unfinished/compiler/tree/strength-reduction/strength-reduction.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.tree.strength-reduction + +: strength-reduce ( nodes -- nodes' ) ; diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor index 9a41181726..b0dde22112 100755 --- a/unfinished/compiler/tree/tree.factor +++ b/unfinished/compiler/tree/tree.factor @@ -6,41 +6,17 @@ accessors combinators stack-checker.state stack-checker.visitor ; IN: compiler.tree ! High-level tree SSA form. -! -! Invariants: -! 1) Each value has exactly one definition. A "definition" means -! the value appears in the out-d or out-r slot of a node, or the -! values slot of an #introduce node. -! 2) Each value appears only once in the inputs of a node, where -! the inputs are the concatenation of in-d and in-r, or in the -! 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 info -successor children ; + +TUPLE: node < identity-tuple info ; M: node hashcode* drop node hashcode* ; -: node-child ( node -- child ) children>> first ; +TUPLE: #introduce < node value ; -: last-node ( node -- last ) - dup successor>> [ last-node ] [ ] ?if ; +: #introduce ( value -- node ) + \ #introduce new swap >>value ; -: penultimate-node ( node -- penultimate ) - dup successor>> dup [ - dup successor>> - [ nip penultimate-node ] [ drop ] if - ] [ - 2drop f - ] if ; - -TUPLE: #introduce < node values ; - -: #introduce ( values -- node ) - \ #introduce new swap >>values ; - -TUPLE: #call < node word history ; +TUPLE: #call < node word history in-d out-d ; : #call ( inputs outputs word -- node ) \ #call new @@ -48,7 +24,7 @@ TUPLE: #call < node word history ; swap >>out-d swap >>in-d ; -TUPLE: #call-recursive < node label ; +TUPLE: #call-recursive < node label in-d out-d ; : #call-recursive ( inputs outputs label -- node ) \ #call-recursive new @@ -56,14 +32,14 @@ TUPLE: #call-recursive < node label ; swap >>out-d swap >>in-d ; -TUPLE: #push < node literal ; +TUPLE: #push < node literal out-d ; : #push ( literal value -- node ) \ #push new swap 1array >>out-d swap >>literal ; -TUPLE: #shuffle < node mapping ; +TUPLE: #shuffle < node mapping in-d out-d ; : #shuffle ( inputs outputs mapping -- node ) \ #shuffle new @@ -74,27 +50,27 @@ TUPLE: #shuffle < node mapping ; : #drop ( inputs -- node ) { } { } #shuffle ; -TUPLE: #>r < node ; +TUPLE: #>r < node in-d out-r ; : #>r ( inputs outputs -- node ) \ #>r new swap >>out-r swap >>in-d ; -TUPLE: #r> < node ; +TUPLE: #r> < node in-r out-d ; : #r> ( inputs outputs -- node ) \ #r> new swap >>out-d swap >>in-r ; -TUPLE: #terminate < node ; +TUPLE: #terminate < node in-d ; : #terminate ( stack -- node ) \ #terminate new swap >>in-d ; -TUPLE: #branch < node ; +TUPLE: #branch < node in-d children ; : new-branch ( value children class -- node ) new @@ -111,7 +87,7 @@ TUPLE: #dispatch < #branch ; : #dispatch ( n branches -- node ) \ #dispatch new-branch ; -TUPLE: #phi < node phi-in-d phi-in-r ; +TUPLE: #phi < node phi-in-d phi-in-r out-d out-r ; : #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node ) \ #phi new @@ -126,22 +102,22 @@ TUPLE: #declare < node declaration ; \ #declare new swap >>declaration ; -TUPLE: #return < node ; +TUPLE: #return < node in-d ; : #return ( stack -- node ) \ #return new swap >>in-d ; -TUPLE: #recursive < node word label loop? returns calls ; +TUPLE: #recursive < node in-d word label loop? returns calls child ; : #recursive ( word label inputs child -- node ) \ #recursive new - swap 1array >>children + swap >>child swap >>in-d swap >>label swap >>word ; -TUPLE: #enter-recursive < node label ; +TUPLE: #enter-recursive < node in-d out-d label ; : #enter-recursive ( label inputs outputs -- node ) \ #enter-recursive new @@ -149,7 +125,7 @@ TUPLE: #enter-recursive < node label ; swap >>in-d swap >>label ; -TUPLE: #return-recursive < node label ; +TUPLE: #return-recursive < node in-d out-d label ; : #return-recursive ( label inputs outputs -- node ) \ #return-recursive new @@ -157,44 +133,31 @@ TUPLE: #return-recursive < node label ; swap >>in-d swap >>label ; -TUPLE: #copy < node ; +TUPLE: #copy < node in-d out-d ; : #copy ( inputs outputs -- node ) \ #copy new swap >>out-d swap >>in-d ; -DEFER: #tail? +: node, ( node -- ) stack-visitor get push ; -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 #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 #enter-recursive, #enter-recursive node, ; -M: node-list #return-recursive, #return-recursive [ node, ] [ dup label>> (>>return) ] bi ; -M: node-list #call-recursive, #call-recursive [ node, ] [ dup label>> calls>> push ] bi ; -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, ; +M: vector child-visitor V{ } clone ; +M: vector #introduce, #introduce node, ; +M: vector #call, #call node, ; +M: vector #push, #push node, ; +M: vector #shuffle, #shuffle node, ; +M: vector #drop, #drop node, ; +M: vector #>r, #>r node, ; +M: vector #r>, #r> node, ; +M: vector #return, #return node, ; +M: vector #enter-recursive, #enter-recursive node, ; +M: vector #return-recursive, #return-recursive node, ; +M: vector #call-recursive, #call-recursive node, ; +M: vector #terminate, #terminate node, ; +M: vector #if, #if node, ; +M: vector #dispatch, #dispatch node, ; +M: vector #phi, #phi node, ; +M: vector #declare, #declare node, ; +M: vector #recursive, #recursive node, ; +M: vector #copy, #copy node, ; diff --git a/unfinished/compiler/tree/untupling/untupling.factor b/unfinished/compiler/tree/untupling/untupling.factor index ebc43ece08..7286e6fb65 100644 --- a/unfinished/compiler/tree/untupling/untupling.factor +++ b/unfinished/compiler/tree/untupling/untupling.factor @@ -3,7 +3,8 @@ 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 ; +compiler.tree.dataflow-analysis +compiler.tree.dataflow-analysis.backward ; IN: compiler.tree.untupling SYMBOL: escaping-values diff --git a/unfinished/stack-checker/backend/backend.factor b/unfinished/stack-checker/backend/backend.factor index 2977f2520a..658a1e9fa1 100755 --- a/unfinished/stack-checker/backend/backend.factor +++ b/unfinished/stack-checker/backend/backend.factor @@ -41,7 +41,7 @@ SYMBOL: visited : pop-d ( -- obj ) meta-d get dup empty? [ - drop dup 1array #introduce, d-in inc + drop dup #introduce, d-in inc ] [ pop ] if ; : peek-d ( -- obj ) pop-d dup push-d ; @@ -52,8 +52,11 @@ SYMBOL: visited : ensure-d ( n -- values ) consume-d dup output-d ; +: make-values ( n -- values ) + [ ] replicate ; + : produce-d ( n -- values ) - [ ] replicate dup meta-d get push-all ; + make-values dup meta-d get push-all ; : push-r ( obj -- ) meta-r get push ; diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor index 231b0ab9bf..ce30d12c7e 100644 --- a/unfinished/stack-checker/visitor/visitor.factor +++ b/unfinished/stack-checker/visitor/visitor.factor @@ -9,7 +9,7 @@ HOOK: child-visitor stack-visitor ( -- visitor ) : nest-visitor ( -- ) child-visitor stack-visitor set ; -HOOK: #introduce, stack-visitor ( values -- ) +HOOK: #introduce, stack-visitor ( value -- ) HOOK: #call, stack-visitor ( inputs outputs word -- ) HOOK: #call-recursive, stack-visitor ( inputs outputs word -- ) HOOK: #push, stack-visitor ( literal value -- ) From 9cc761d8991f5cd60e559b11e8bef1ea7f863dd9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Jul 2008 22:45:46 -0500 Subject: [PATCH 08/65] More efficient branch? word --- extra/sequences/deep/deep.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/extra/sequences/deep/deep.factor b/extra/sequences/deep/deep.factor index 3ec793f458..2e50fa5411 100644 --- a/extra/sequences/deep/deep.factor +++ b/extra/sequences/deep/deep.factor @@ -5,10 +5,12 @@ IN: sequences.deep ! All traversal goes in postorder -: branch? ( object -- ? ) - dup sequence? [ - dup string? swap number? or not - ] [ drop f ] if ; +GENERIC: branch? ( object -- ? ) + +M: sequence branch? drop t ; +M: integer branch? drop f ; +M: string branch? drop f ; +M: object branch? drop f ; : deep-each ( obj quot: ( elt -- ) -- ) [ call ] 2keep over branch? From 9d248286045f3dd8f003c4292d711be65d2f813a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Jul 2008 22:47:40 -0500 Subject: [PATCH 09/65] Beefed up normalization pass cleans up stack usage, simplifying recursive propagation --- .../tree/combinators/combinators-tests.factor | 1 + .../tree/combinators/combinators.factor | 15 +++- .../tree/copy-equiv/copy-equiv.factor | 7 -- .../normalization/normalization-tests.factor | 10 +-- .../tree/normalization/normalization.factor | 79 +++++++++++++------ .../tree/propagation/propagation-tests.factor | 7 ++ .../propagation/recursive/recursive.factor | 35 +++----- .../stack-checker/inlining/inlining.factor | 2 +- 8 files changed, 95 insertions(+), 61 deletions(-) diff --git a/unfinished/compiler/tree/combinators/combinators-tests.factor b/unfinished/compiler/tree/combinators/combinators-tests.factor index 12ab7e3563..66ad5e11f4 100644 --- a/unfinished/compiler/tree/combinators/combinators-tests.factor +++ b/unfinished/compiler/tree/combinators/combinators-tests.factor @@ -2,3 +2,4 @@ IN: compiler.tree.combinators.tests USING: compiler.tree.combinators tools.test kernel ; { 1 0 } [ [ drop ] each-node ] must-infer-as +{ 1 1 } [ [ ] map-nodes ] must-infer-as diff --git a/unfinished/compiler/tree/combinators/combinators.factor b/unfinished/compiler/tree/combinators/combinators.factor index 94bcdb2d95..eafbb198a1 100644 --- a/unfinished/compiler/tree/combinators/combinators.factor +++ b/unfinished/compiler/tree/combinators/combinators.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry kernel accessors sequences compiler.tree ; +USING: fry kernel accessors sequences sequences.deep +compiler.tree ; IN: compiler.tree.combinators : each-node ( nodes quot -- ) @@ -15,3 +16,15 @@ IN: compiler.tree.combinators ] if ] bi ] each ; inline + +: map-nodes ( nodes quot: ( node -- node' ) -- nodes ) + dup dup '[ + @ + dup #branch? [ + [ [ , map-nodes ] map ] change-children + ] [ + dup #recursive? [ + [ , map-nodes ] change-child + ] when + ] if + ] map flatten ; inline recursive diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor index 2b7b6c5ecb..a414554efc 100644 --- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor +++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor @@ -34,13 +34,6 @@ M: #copy compute-copy-equiv* M: #return-recursive compute-copy-equiv* [ in-d>> ] [ out-d>> ] bi are-copies-of ; -: unchanged-underneath ( #call-recursive -- n ) - [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ; - -M: #call-recursive compute-copy-equiv* - [ in-d>> ] [ out-d>> ] [ unchanged-underneath ] tri - '[ , head ] bi@ are-copies-of ; - M: node compute-copy-equiv* drop ; : compute-copy-equiv ( node -- node ) diff --git a/unfinished/compiler/tree/normalization/normalization-tests.factor b/unfinished/compiler/tree/normalization/normalization-tests.factor index 39a71ad0a6..91c11f3be6 100644 --- a/unfinished/compiler/tree/normalization/normalization-tests.factor +++ b/unfinished/compiler/tree/normalization/normalization-tests.factor @@ -2,18 +2,18 @@ IN: compiler.tree.normalization.tests USING: compiler.tree.builder compiler.tree.normalization compiler.tree sequences accessors tools.test kernel ; -\ collect-introductions must-infer +\ count-introductions must-infer \ fixup-enter-recursive must-infer \ eliminate-introductions must-infer \ normalize must-infer -[ 3 ] [ [ 3drop 1 2 3 ] build-tree collect-introductions ] unit-test +[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test -[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree collect-introductions ] unit-test +[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test -[ 3 ] [ [ [ drop ] [ 2drop 3 ] if ] build-tree collect-introductions ] unit-test +[ 3 ] [ [ [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test -[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree collect-introductions ] unit-test +[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test : foo ( -- ) swap ; inline recursive diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor index 38fa3e11b3..976d51dfb6 100644 --- a/unfinished/compiler/tree/normalization/normalization.factor +++ b/unfinished/compiler/tree/normalization/normalization.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces sequences math accessors kernel arrays -stack-checker.backend compiler.tree compiler.tree.combinators ; +USING: fry namespaces sequences math accessors kernel arrays +stack-checker.backend stack-checker.inlining compiler.tree +compiler.tree.combinators ; IN: compiler.tree.normalization ! A transform pass done before optimization can begin to @@ -13,29 +14,52 @@ IN: compiler.tree.normalization ! ! - We collect #return-recursive and #call-recursive nodes and ! store them in the #recursive's label slot. - -GENERIC: normalize* ( node -- ) +! +! - We normalize #call-recursive as follows. The stack checker +! says that the inputs of a #call-recursive are the entire stack +! at the time of the call. This is a conservative estimate; we +! don't know the exact number of stack values it touches until +! the #return-recursive node has been visited, because of row +! polymorphism. So in the normalize pass, we split a +! #call-recursive into a #copy of the unchanged values and a +! #call-recursive with trimmed inputs and outputs. ! Collect introductions SYMBOL: introductions -GENERIC: collect-introductions* ( node -- ) +GENERIC: count-introductions* ( node -- ) -: collect-introductions ( nodes -- n ) +: count-introductions ( nodes -- n ) + #! Note: we use each, not each-node, since the #branch + #! method recurses into children directly and we don't + #! recurse into #recursive at all. [ 0 introductions set - [ collect-introductions* ] each + [ count-introductions* ] each introductions get ] with-scope ; -M: #introduce collect-introductions* drop introductions inc ; +M: #introduce count-introductions* drop introductions inc ; -M: #branch collect-introductions* +M: #branch count-introductions* children>> - [ collect-introductions ] map supremum + [ count-introductions ] map supremum introductions [ + ] change ; -M: node collect-introductions* drop ; +M: node count-introductions* drop ; + +! Collect label info +GENERIC: collect-label-info ( node -- ) + +M: #return-recursive collect-label-info dup label>> (>>return) ; + +M: #call-recursive collect-label-info dup label>> calls>> push ; + +M: #recursive collect-label-info + [ label>> ] [ child>> count-introductions ] bi + >>introductions drop ; + +M: node collect-label-info drop ; ! Eliminate introductions SYMBOL: introduction-stack @@ -73,22 +97,29 @@ M: #phi eliminate-introductions* M: node eliminate-introductions* ; : eliminate-introductions ( recursive n -- ) - make-values introduction-stack set - [ fixup-enter-recursive ] - [ child>> [ eliminate-introductions* ] change-each ] bi ; + make-values introduction-stack [ + [ fixup-enter-recursive ] + [ child>> [ eliminate-introductions* ] change-each ] bi + ] with-variable ; + +! Normalize +GENERIC: normalize* ( node -- node' ) M: #recursive normalize* - [ - [ child>> collect-introductions ] - [ swap eliminate-introductions ] - bi - ] with-scope ; + dup dup label>> introductions>> eliminate-introductions ; -! Collect label info -M: #return-recursive normalize* dup label>> (>>return) ; +: unchanged-underneath ( #call-recursive -- n ) + [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ; -M: #call-recursive normalize* dup label>> calls>> push ; +M: #call-recursive normalize* + dup unchanged-underneath + [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ #copy ] + [ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ] + 2bi 2array ; -M: node normalize* drop ; +M: node normalize* ; -: normalize ( node -- node ) dup [ normalize* ] each-node ; +: normalize ( nodes -- nodes' ) + [ [ collect-label-info ] each-node ] + [ [ normalize* ] map-nodes ] + bi ; diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index f15927c8f4..6deb80947a 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -406,3 +406,10 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-6 swap 2 - recursive-test-6 + ] if ; inline recursive [ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test + +: recursive-test-7 ( a -- b ) + dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive + +[ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test + +[ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index e1905d5b44..8f50add191 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -10,33 +10,25 @@ compiler.tree.propagation.simple compiler.tree.propagation.branches ; IN: compiler.tree.propagation.recursive -! row polymorphism is causing problems - -: longest-suffix ( seq1 seq2 -- seq1' seq2' ) - 2dup min-length [ tail-slice* ] curry bi@ ; - -: suffixes= ( seq1 seq2 -- ? ) - longest-suffix sequence= ; - : check-fixed-point ( node infos1 infos2 -- node ) - suffixes= [ dup label>> f >>fixed-point drop ] unless ; inline + sequence= [ dup label>> f >>fixed-point drop ] unless ; inline : recursive-stacks ( #enter-recursive -- stacks initial ) - [ label>> calls>> [ node-input-infos ] map ] - [ in-d>> [ value-info ] map ] bi - [ length '[ , tail* ] map flip ] keep ; + [ label>> calls>> [ node-input-infos ] map flip ] + [ in-d>> [ value-info ] map ] bi ; -: generalize-counter-interval ( i1 i2 -- i3 ) +: generalize-counter-interval ( interval initial-interval -- interval' ) { - { [ 2dup interval<= ] [ 1./0. [a,a] ] } - { [ 2dup interval>= ] [ -1./0. [a,a] ] } + { [ 2dup = ] [ empty-interval ] } + { [ over empty-interval eq? ] [ empty-interval ] } + { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] } + { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] } [ [-inf,inf] ] } cond nip interval-union ; : generalize-counter ( info' initial -- info ) [ drop clone ] [ [ interval>> ] bi@ ] 2bi - generalize-counter-interval >>interval - f >>literal? f >>literal ; + generalize-counter-interval >>interval ; : unify-recursive-stacks ( stacks initial -- infos ) over empty? [ nip ] [ @@ -72,12 +64,9 @@ M: #recursive propagate-around ( #recursive -- ) [ generalize-return-interval ] map ; M: #call-recursive propagate-before ( #call-label -- ) - dup - [ node-output-infos ] - [ label>> return>> node-input-infos ] - bi check-fixed-point - [ label>> return>> node-input-infos generalize-return ] [ out-d>> ] bi - longest-suffix set-value-infos ; + dup [ node-output-infos ] [ label>> return>> node-input-infos ] bi + [ check-fixed-point ] keep + generalize-return swap out-d>> set-value-infos ; M: #return-recursive propagate-before ( #return-recursive -- ) dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor index 5dc159bcc4..ace1a043cb 100644 --- a/unfinished/stack-checker/inlining/inlining.factor +++ b/unfinished/stack-checker/inlining/inlining.factor @@ -17,7 +17,7 @@ IN: stack-checker.inlining : (inline-word) ( word label -- ) [ [ def>> ] keep ] dip infer-quot-recursive ; -TUPLE: inline-recursive word enter-out return calls fixed-point ; +TUPLE: inline-recursive word enter-out return calls fixed-point introductions ; : ( word -- label ) inline-recursive new From 1c091ed24b04cc85f639616af2e0ba80d71aef1b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 00:48:29 -0500 Subject: [PATCH 10/65] processing.shapes: Factor out shape drawing code. It is not specific to processing. --- extra/processing/shapes/shapes.factor | 112 ++++++++++++++++++++++++++ 1 file changed, 112 insertions(+) create mode 100644 extra/processing/shapes/shapes.factor diff --git a/extra/processing/shapes/shapes.factor b/extra/processing/shapes/shapes.factor new file mode 100644 index 0000000000..6f680a87e6 --- /dev/null +++ b/extra/processing/shapes/shapes.factor @@ -0,0 +1,112 @@ + +USING: kernel namespaces arrays sequences grouping + alien.c-types + math math.vectors math.geometry.rect + opengl.gl opengl.glu opengl generalizations vars + combinators.cleave ; + +IN: processing.shapes + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: fill-color +VAR: stroke-color + +{ 0 0 0 1 } stroke-color set-global +{ 1 1 1 1 } fill-color set-global + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fill-mode ( -- ) + GL_FRONT_AND_BACK GL_FILL glPolygonMode + fill-color> first4 glColor4d ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: stroke-mode ( -- ) + GL_FRONT_AND_BACK GL_LINE glPolygonMode + stroke-color> first4 glColor4d ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gl-vertex-2d ( vertex -- ) first2 glVertex2d ; + +: gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ; +: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ; +: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: line** ( x y x y -- ) + stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ; + +: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ; + +: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ; + +: line ( seq -- ) lines ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: triangles ( seq -- ) + [ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] + [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ; + +: triangle ( seq -- ) triangles ; + +: triangle* ( a b c -- ) 3array triangles ; + +: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: polygon ( seq -- ) + [ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ] + [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rectangle ( loc dim -- ) + + { top-left top-right bottom-right bottom-left } + 1arr + polygon ; + +: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gl-translate-2d ( pos -- ) first2 0 glTranslated ; + +: gl-scale-2d ( xy -- ) first2 1 glScaled ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gl-ellipse ( center dim -- ) + glPushMatrix + [ gl-translate-2d ] [ gl-scale-2d ] bi* + gluNewQuadric + dup 0 0.5 20 1 gluDisk + gluDeleteQuadric + glPopMatrix ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gl-get-line-width ( -- width ) + GL_LINE_WIDTH 0 tuck glGetDoublev *double ; + +: ellipse ( center dim -- ) + GL_FRONT_AND_BACK GL_FILL glPolygonMode + [ stroke-color> gl-color gl-ellipse ] + [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: circle ( center size -- ) dup 2array ellipse ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From d6ad62ebf031a247b97ad0b47667df1006de6230 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 00:49:34 -0500 Subject: [PATCH 11/65] golden-section: Use processing.shapes --- extra/golden-section/golden-section.factor | 24 ++++++++-------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/extra/golden-section/golden-section.factor b/extra/golden-section/golden-section.factor index 8ae8bccc25..a83dc988fd 100644 --- a/extra/golden-section/golden-section.factor +++ b/extra/golden-section/golden-section.factor @@ -1,21 +1,14 @@ -USING: kernel namespaces math math.constants math.functions arrays sequences +USING: kernel namespaces math math.constants math.functions math.order + arrays sequences opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme - ui.gadgets.slate colors accessors combinators.cleave ; + ui.gadgets.slate colors accessors combinators.cleave + processing.shapes ; IN: golden-section ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: disk ( radius center -- ) - glPushMatrix - gl-translate - dup 0 glScalef - gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi - glPopMatrix ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! omega(i) = 2*pi*i*(phi-1) ! x(i) = 0.5*i*cos(omega(i)) @@ -34,12 +27,13 @@ IN: golden-section : radius ( i -- radius ) pi * 720 / sin 10 * ; -: color ( i -- color ) 360.0 / dup 0.25 1 4array ; +: color ( i -- i ) dup 360.0 / dup 0.25 1 4array >fill-color ; -: rim ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ; -: inner ( i -- ) [ color gl-color ] [ radius ] [ center ] tri disk ; +: line-width ( i -- i ) dup radius 0.5 * 1 max glLineWidth ; -: dot ( i -- ) [ rim ] [ inner ] bi ; +: draw ( i -- ) [ center ] [ radius 1.5 * 2 * ] bi circle ; + +: dot ( i -- ) color line-width draw ; : golden-section ( -- ) 720 [ dot ] each ; From 7a3a0d3677b523442b11b605f888ba7bb91fb6f6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 00:50:08 -0500 Subject: [PATCH 12/65] boids: Up the initial boids count to 100 --- extra/boids/boids.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index ab624a606b..8c045ee270 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -220,7 +220,7 @@ cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: init-boids ( -- ) 50 random-boids >boids ; +: init-boids ( -- ) 100 random-boids >boids ; : init-world-size ( -- ) { 100 100 } >world-size ; From 86a881f1f2b8facdb37258610f87298abffa0963 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 00:50:22 -0500 Subject: [PATCH 13/65] boids.ui: Use processing.shapes --- extra/boids/ui/ui.factor | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index 064eda841b..f380441960 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -1,6 +1,7 @@ USING: combinators.short-circuit kernel namespaces math + math.trig math.functions math.vectors math.parser @@ -21,7 +22,8 @@ USING: combinators.short-circuit kernel namespaces ui.gestures assocs.lib vars rewrite-closures boids accessors math.geometry.rect - newfx ; + newfx + processing.shapes ; IN: boids.ui @@ -29,17 +31,22 @@ IN: boids.ui ! draw-boid ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: point-a ( boid -- a ) pos>> ; - -: point-b ( boid -- b ) [ pos>> ] [ vel>> normalize* 20 v*n ] bi v+ ; - -: boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ; - -: draw-boid ( boid -- ) boid-points gl-line ; +: draw-boid ( boid -- ) + glPushMatrix + dup pos>> gl-translate-2d + vel>> first2 rect> arg rad>deg 0 0 1 glRotated + { { 0 5 } { 0 -5 } { 20 0 } } triangle + glPopMatrix ; : draw-boids ( -- ) boids> [ draw-boid ] each ; -: display ( -- ) black gl-color draw-boids ; +: boid-color ( -- color ) { 1.0 0 0 0.3 } ; + +: display ( -- ) + white gl-clear + boid-color >fill-color + 2 glLineWidth + draw-boids ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From d2352a15e6b5e039d4e249b590ce37b4ea9e8c7c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 01:41:10 -0500 Subject: [PATCH 14/65] processing.shapes: Use 'gl-color' in a couple of places --- extra/processing/shapes/shapes.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/processing/shapes/shapes.factor b/extra/processing/shapes/shapes.factor index 6f680a87e6..16530c5414 100644 --- a/extra/processing/shapes/shapes.factor +++ b/extra/processing/shapes/shapes.factor @@ -19,13 +19,13 @@ VAR: stroke-color : fill-mode ( -- ) GL_FRONT_AND_BACK GL_FILL glPolygonMode - fill-color> first4 glColor4d ; + fill-color> gl-color ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : stroke-mode ( -- ) GL_FRONT_AND_BACK GL_LINE glPolygonMode - stroke-color> first4 glColor4d ; + stroke-color> gl-color ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 4f10ed4aaf1dd545c2e44a8266e27f8ebe0c12e8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 01:41:49 -0500 Subject: [PATCH 15/65] boids.ui: Add workaround for display glitch --- extra/boids/ui/ui.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index f380441960..38dd9b4f78 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -36,6 +36,7 @@ IN: boids.ui dup pos>> gl-translate-2d vel>> first2 rect> arg rad>deg 0 0 1 glRotated { { 0 5 } { 0 -5 } { 20 0 } } triangle + fill-mode glPopMatrix ; : draw-boids ( -- ) boids> [ draw-boid ] each ; @@ -43,9 +44,7 @@ IN: boids.ui : boid-color ( -- color ) { 1.0 0 0 0.3 } ; : display ( -- ) - white gl-clear boid-color >fill-color - 2 glLineWidth draw-boids ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From ed7ad146d8ba10c92ed217ddf07bceed805a64a4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 28 Jul 2008 06:31:11 -0500 Subject: [PATCH 16/65] Fix NaN handling in math.intervals --- core/math/intervals/intervals.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 8afbee3478..6e50f42726 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. ! Based on Slate's src/unfinished/interval.slate by Brian Rice. USING: accessors kernel sequences arrays math math.order @@ -76,9 +76,11 @@ TUPLE: interval { from read-only } { to read-only } ; [ from>> ] [ to>> ] bi ; : points>interval ( seq -- interval ) - dup first - [ [ endpoint-min ] reduce ] 2keep - [ endpoint-max ] reduce ; + dup [ first fp-nan? ] contains? [ drop [-inf,inf] ] [ + dup first + [ [ endpoint-min ] reduce ] 2keep + [ endpoint-max ] reduce + ] if ; : (interval-op) ( p1 p2 quot -- p3 ) [ [ first ] [ first ] [ ] tri* call ] From d817efe1dd4dad34323b51876b48d6f514057504 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 28 Jul 2008 06:31:26 -0500 Subject: [PATCH 17/65] Working on predicate constraint propagation --- .../tree/copy-equiv/copy-equiv.factor | 13 +++ .../tree/elaboration/elaboration.factor | 5 + .../compiler/tree/optimizer/optimizer.factor | 3 +- .../tree/propagation/branches/branches.factor | 104 ++++++++++++++---- .../constraints/constraints.factor | 82 ++++++-------- .../tree/propagation/info/info.factor | 11 +- .../known-words/known-words.factor | 11 +- .../tree/propagation/propagation-tests.factor | 38 +++++++ .../propagation/recursive/recursive.factor | 15 ++- .../tree/propagation/simple/simple.factor | 7 +- .../tree/propagation/slots/slots.factor | 2 +- unfinished/compiler/tree/tree.factor | 2 +- .../stack-checker/backend/backend.factor | 2 +- 13 files changed, 203 insertions(+), 92 deletions(-) create mode 100644 unfinished/compiler/tree/elaboration/elaboration.factor diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor index a414554efc..b45bc4bbe2 100644 --- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor +++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor @@ -34,6 +34,19 @@ M: #copy compute-copy-equiv* M: #return-recursive compute-copy-equiv* [ in-d>> ] [ out-d>> ] bi are-copies-of ; +: compute-phi-equiv ( inputs outputs -- ) + #! An output is a copy of every input if all inputs are + #! copies of the same original value. + [ + swap [ resolve-copy ] map sift + dup [ all-equal? ] [ empty? not ] bi and + [ first swap is-copy-of ] [ 2drop ] if + ] 2each ; + +M: #phi compute-copy-equiv* + [ [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ] + [ [ phi-in-r>> ] [ out-r>> ] bi compute-phi-equiv ] bi ; + M: node compute-copy-equiv* drop ; : compute-copy-equiv ( node -- node ) diff --git a/unfinished/compiler/tree/elaboration/elaboration.factor b/unfinished/compiler/tree/elaboration/elaboration.factor new file mode 100644 index 0000000000..b0f4306964 --- /dev/null +++ b/unfinished/compiler/tree/elaboration/elaboration.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.tree.elaboration + +: elaborate ( nodes -- nodes' ) ; diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor index bb33deb7e7..753c962061 100644 --- a/unfinished/compiler/tree/optimizer/optimizer.factor +++ b/unfinished/compiler/tree/optimizer/optimizer.factor @@ -18,4 +18,5 @@ IN: compiler.tree.optimizer remove-dead-code strength-reduce detect-loops - fuse-branches ; + fuse-branches + elaborate ; diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index a8b623eb51..9480033ccc 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/unfinished/compiler/tree/propagation/branches/branches.factor @@ -1,7 +1,7 @@ ! 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 locals +math.intervals arrays classes.algebra combinators compiler.tree compiler.tree.def-use compiler.tree.propagation.info @@ -33,12 +33,15 @@ M: #dispatch live-children SYMBOL: infer-children-data +: copy-value-info ( -- ) + value-infos [ clone ] change + constraints [ clone ] change ; + : infer-children ( node -- ) [ live-children ] [ child-constraints ] bi [ [ over [ - value-infos [ clone ] change - constraints [ clone ] change + copy-value-info assume (propagate) ] [ @@ -49,31 +52,86 @@ SYMBOL: infer-children-data ] H{ } make-assoc ] 2map infer-children-data set ; -: (merge-value-infos) ( inputs results -- infos ) - '[ , [ [ value-info ] bind ] 2map value-infos-union ] map ; +: compute-phi-input-infos ( phi-in -- phi-info ) + infer-children-data get + '[ , [ [ value-info ] bind ] 2map ] map ; -: merge-value-infos ( results inputs outputs -- ) - [ swap (merge-value-infos) ] dip set-value-infos ; +: annotate-phi-node ( #phi -- ) + dup phi-in-d>> compute-phi-input-infos >>phi-info-d + dup phi-in-r>> compute-phi-input-infos >>phi-info-r + dup [ out-d>> ] [ out-r>> ] bi append extract-value-info >>info + drop ; + +: merge-value-infos ( infos outputs -- ) + [ [ value-infos-union ] map ] dip set-value-infos ; + +SYMBOL: condition-value + +! :: 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 ; M: #phi propagate-before ( #phi -- ) - infer-children-data get swap - [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ] - [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ] - 2bi ; + [ annotate-phi-node ] + [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ] + [ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ] + tri ; -:: 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 ; +: branch-phi-constraints ( output values booleans -- ) + { + { + { { t } { f } } + [ + drop condition-value get + [ [ =t ] [ =t ] bi* <--> ] + [ [ =f ] [ =f ] bi* <--> ] 2bi /\ assume + ] + } + { + { { f } { t } } + [ + drop condition-value get + [ [ =t ] [ =f ] bi* <--> ] + [ [ =f ] [ =t ] bi* <--> ] 2bi /\ assume + ] + } + { + { { t f } { f } } + [ first =t condition-value get =t /\ swap t--> assume ] + } + { + { { f } { t f } } + [ second =t condition-value get =f /\ swap t--> assume ] + } + ! { + ! { { f } { t f } } + ! [ ] + ! } + [ 3drop ] + } case ; -! : merge-children -! [ successor>> propagate-branch-phi ] -! [ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ] -! bi ; +M: #phi propagate-after ( #phi -- ) + condition-value get [ + [ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri + 3array flip [ + first3 [ possible-boolean-values ] map + branch-phi-constraints + ] each + ] [ drop ] if ; + +M: #phi propagate-around ( #phi -- ) + [ propagate-before ] [ propagate-after ] bi ; M: #branch propagate-around [ infer-children ] [ annotate-node ] bi ; + +M: #if propagate-around + [ in-d>> first condition-value set ] [ call-next-method ] bi ; + +M: #dispatch propagate-around + condition-value off call-next-method ; diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor index 42c094db5a..0b19d34a20 100644 --- a/unfinished/compiler/tree/propagation/constraints/constraints.factor +++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor @@ -12,38 +12,42 @@ IN: compiler.tree.propagation.constraints ! Maps constraints to constraints ("A implies B") SYMBOL: constraints -GENERIC: assume ( constraint -- ) +GENERIC: assume* ( constraint -- ) GENERIC: satisfied? ( constraint -- ? ) -GENERIC: satisfiable? ( constraint -- ? ) + +M: f assume* drop ; + +! satisfied? is inaccurate. It's just used to prevent infinite +! loops so its only implemented for true-constraints and +! false-constraints. +M: object satisfied? drop f ; + +: assume ( constraint -- ) dup satisfied? [ drop ] [ assume* ] if ; ! Boolean constraints TUPLE: true-constraint value ; : =t ( value -- constriant ) resolve-copy true-constraint boa ; -M: true-constraint assume - [ constraints get at [ assume ] when* ] +M: true-constraint assume* [ \ f class-not swap value>> refine-value-info ] + [ constraints get at [ assume ] when* ] bi ; -M: true-constraint satisfied? value>> \ f class-not value-is? ; - -M: true-constraint satisfiable? value>> \ f class-not value-is? ; +M: true-constraint satisfied? + value>> value-info class>> true-class? ; TUPLE: false-constraint value ; : =f ( value -- constriant ) resolve-copy false-constraint boa ; -M: false-constraint assume - [ constraints get at [ assume ] when* ] +M: false-constraint assume* [ \ f swap value>> refine-value-info ] + [ constraints get at [ assume ] when* ] bi ; M: false-constraint satisfied? - value>> value-info class>> \ f class<= ; - -M: false-constraint satisfiable? - value>> value-info class>> \ f classes-intersect? ; + value>> value-info class>> false-class? ; ! Class constraints TUPLE: class-constraint value class ; @@ -51,7 +55,7 @@ TUPLE: class-constraint value class ; : is-instance-of ( value class -- constraint ) [ resolve-copy ] dip class-constraint boa ; -M: class-constraint assume +M: class-constraint assume* [ class>> ] [ value>> ] bi refine-value-info ; ! Interval constraints @@ -60,7 +64,7 @@ TUPLE: interval-constraint value interval ; : is-in-interval ( value interval -- constraint ) [ resolve-copy ] dip interval-constraint boa ; -M: interval-constraint assume +M: interval-constraint assume* [ interval>> ] [ value>> ] bi refine-value-info ; ! Literal constraints @@ -69,7 +73,7 @@ TUPLE: literal-constraint value literal ; : is-equal-to ( value literal -- constraint ) [ resolve-copy ] dip literal-constraint boa ; -M: literal-constraint assume +M: literal-constraint assume* [ literal>> ] [ value>> ] bi refine-value-info ; ! Implication constraints @@ -77,46 +81,32 @@ TUPLE: implication p q ; C: --> implication -M: implication assume - [ q>> ] [ p>> ] bi - [ constraints get set-at ] +: assume-implication ( p q -- ) + [ constraints get [ swap suffix ] change-at ] [ satisfied? [ assume ] [ drop ] if ] 2bi ; -M: implication satisfiable? - [ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ; +M: implication assume* + [ q>> ] [ p>> ] bi assume-implication ; -! Conjunction constraints -TUPLE: conjunction p q ; +! Equivalence constraints +TUPLE: equivalence p q ; -C: /\ conjunction +C: <--> equivalence -M: conjunction assume [ p>> assume ] [ q>> assume ] bi ; +M: equivalence assume* + [ p>> ] [ q>> ] bi + [ assume-implication ] + [ swap assume-implication ] 2bi ; -M: conjunction satisfiable? - [ p>> satisfiable? ] [ q>> satisfiable? ] bi and ; +! Conjunction constraints -- sequences act as conjunctions +M: sequence assume* [ assume ] each ; -! 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 ; +: /\ ( p q -- constraint ) 2array ; ! Utilities : t--> ( constraint boolean-value -- constraint' ) =t swap --> ; : f--> ( constraint boolean-value -- constraint' ) =f swap --> ; -: ( true-constr false-constr boolean-value -- constraint ) - tuck [ t--> ] [ f--> ] 2bi* /\ ; +: save-constraints ( quot -- ) + constraints get clone slip constraints set ; inline diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 8c76f9330c..166cc08c17 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -220,21 +220,22 @@ SYMBOL: value-infos : value-literal ( value -- obj ? ) value-info >literal< ; +: false-class? ( class -- ? ) \ f class<= ; + +: true-class? ( class -- ? ) \ f class-not class<= ; + : possible-boolean-values ( info -- values ) dup literal?>> [ literal>> 1array ] [ class>> { { [ dup null class<= ] [ { } ] } - { [ dup \ f class-not class<= ] [ { t } ] } - { [ dup \ f class<= ] [ { f } ] } + { [ dup true-class? ] [ { t } ] } + { [ dup false-class? ] [ { f } ] } [ { t f } ] } cond nip ] if ; -: value-is? ( value class -- ? ) - [ value-info class>> ] dip class<= ; - : node-value-info ( node value -- info ) swap info>> at* [ drop null-info ] unless ; diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor index eef34f6f8f..e0a341f66a 100644 --- a/unfinished/compiler/tree/propagation/known-words/known-words.factor +++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor @@ -149,12 +149,9 @@ most-negative-fixnum most-positive-fixnum [a,b] /\ ] ; -: comparison-constraints ( in1 in2 out op -- constraint ) - swap [ - [ (comparison-constraints) ] - [ negate-comparison (comparison-constraints) ] - 3bi - ] dip ; +:: comparison-constraints ( in1 in2 out op -- constraint ) + in1 in2 op (comparison-constraints) out t--> + in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ; : define-comparison-constraints ( word op -- ) '[ , comparison-constraints ] +constraints+ set-word-prop ; @@ -204,7 +201,7 @@ generic-comparison-ops [ \ eq? [ [ info-intervals-intersect? ] [ info-classes-intersect? ] - bi or maybe-or-never + 2bi or maybe-or-never ] +outputs+ set-word-prop { diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 6deb80947a..4da40f8a2d 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -129,6 +129,36 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ string } ] [ + [ dup string? not [ "Oops" throw ] [ ] if ] final-classes +] unit-test + +[ V{ string } ] [ + [ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes +] unit-test + +[ V{ string } ] [ + [ dup string? t xor [ "A" throw ] [ ] if ] final-classes +] unit-test + +[ t ] [ [ t or ] final-classes first true-class? ] unit-test + +[ t ] [ [ t swap or ] final-classes first true-class? ] unit-test + +[ t ] [ [ f and ] final-classes first false-class? ] unit-test + +[ t ] [ [ f swap and ] final-classes first false-class? ] unit-test + +[ t ] [ [ dup not or ] final-classes first true-class? ] unit-test + +[ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test + +[ t ] [ [ dup not and ] final-classes first false-class? ] unit-test + +[ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test + +[ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test + [ V{ fixnum } ] [ [ >fixnum @@ -240,6 +270,12 @@ IN: compiler.tree.propagation.tests [ 0 * 10 < ] final-classes ] unit-test +[ V{ 27 } ] [ + [ + 123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if + ] final-literals +] unit-test + [ V{ string string } ] [ [ 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop @@ -413,3 +449,5 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; [ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test [ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test + +[ V{ integer } ] [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 8f50add191..005199afaf 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -7,7 +7,8 @@ compiler.tree compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.simple -compiler.tree.propagation.branches ; +compiler.tree.propagation.branches +compiler.tree.propagation.constraints ; IN: compiler.tree.propagation.recursive : check-fixed-point ( node infos1 infos2 -- node ) @@ -50,10 +51,14 @@ SYMBOL: iter-counter M: #recursive propagate-around ( #recursive -- ) iter-counter inc iter-counter get 10 > [ "Oops" throw ] when - dup label>> t >>fixed-point drop - [ child>> [ first propagate-recursive-phi ] [ (propagate) ] bi ] - [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] - bi ; + dup label>> t >>fixed-point drop [ + [ + child>> + [ first propagate-recursive-phi ] + [ (propagate) ] + bi + ] save-constraints + ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ; : generalize-return-interval ( info -- info' ) dup literal?>> [ diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index 42468dff8d..f30f154285 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/unfinished/compiler/tree/propagation/simple/simple.factor @@ -16,7 +16,7 @@ M: #introduce propagate-before value>> object swap set-value-info ; M: #push propagate-before - [ literal>> value>> ] [ out-d>> first ] bi + [ literal>> ] [ out-d>> first ] bi set-value-info ; : refine-value-infos ( classes values -- ) @@ -117,10 +117,13 @@ M: #call propagate-after M: node propagate-after drop ; +: extract-value-info ( values -- assoc ) + [ dup value-info ] H{ } map>assoc ; + : annotate-node ( node -- ) dup [ node-defs-values ] [ node-uses-values ] bi append - [ dup value-info ] H{ } map>assoc + extract-value-info >>info drop ; M: node propagate-around diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index c0a445d237..b92479490c 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ; bi value-info-intersect 1array ; : length-accessor? ( node -- ? ) - dup in-d>> first fixed-length-sequence value-is? + dup in-d>> first value-info class>> fixed-length-sequence class<= [ word>> \ length eq? ] [ drop f ] if ; : propagate-length ( node -- infos ) diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor index b0dde22112..7ff798de8f 100755 --- a/unfinished/compiler/tree/tree.factor +++ b/unfinished/compiler/tree/tree.factor @@ -87,7 +87,7 @@ TUPLE: #dispatch < #branch ; : #dispatch ( n branches -- node ) \ #dispatch new-branch ; -TUPLE: #phi < node phi-in-d phi-in-r out-d out-r ; +TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r ; : #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node ) \ #phi new diff --git a/unfinished/stack-checker/backend/backend.factor b/unfinished/stack-checker/backend/backend.factor index 658a1e9fa1..853579217b 100755 --- a/unfinished/stack-checker/backend/backend.factor +++ b/unfinished/stack-checker/backend/backend.factor @@ -74,7 +74,7 @@ SYMBOL: visited GENERIC: apply-object ( obj -- ) : push-literal ( obj -- ) - dup make-known [ nip push-d ] [ #push, ] 2bi ; + dup make-known [ nip push-d ] [ #push, ] 2bi ; M: wrapper apply-object wrapped>> From 7768bae3f6fec72def62ee8fa7dd524c6b937251 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 28 Jul 2008 06:33:06 -0500 Subject: [PATCH 18/65] Remove dead code --- .../tree/propagation/branches/branches.factor | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index 9480033ccc..50e3f5c9e2 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/unfinished/compiler/tree/propagation/branches/branches.factor @@ -67,15 +67,6 @@ SYMBOL: infer-children-data SYMBOL: condition-value -! :: 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 ; - M: #phi propagate-before ( #phi -- ) [ annotate-phi-node ] [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ] @@ -108,10 +99,6 @@ M: #phi propagate-before ( #phi -- ) { { f } { t f } } [ second =t condition-value get =f /\ swap t--> assume ] } - ! { - ! { { f } { t f } } - ! [ ] - ! } [ 3drop ] } case ; From ac23f41198acd8a786d24bac458425f4377b0f88 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 12:54:21 -0500 Subject: [PATCH 19/65] processing: Update to use 'processing.shapes' --- extra/processing/processing.factor | 274 ++++++++++++++--------------- 1 file changed, 128 insertions(+), 146 deletions(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index f786628c79..bcfe314d45 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -10,7 +10,8 @@ USING: kernel namespaces threads combinators sequences arrays combinators.cleave rewrite-closures fry accessors newfx processing.color - processing.gadget math.geometry.rect ; + processing.gadget math.geometry.rect + processing.shapes ; IN: processing @@ -36,53 +37,34 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -VAR: fill-color -VAR: stroke-color +! VAR: fill-color +! VAR: stroke-color ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -GENERIC: set-color ( value -- ) +GENERIC: canonical-color-value ( obj -- color ) -METHOD: set-color { number } dup dup glColor3d ; +METHOD: canonical-color-value { number } dup dup 1 4array ; -METHOD: set-color { array } +METHOD: canonical-color-value { array } dup length { - { 2 [ first2 >r dup dup r> glColor4d ] } - { 3 [ first3 glColor3d ] } - { 4 [ first4 glColor4d ] } + { 2 [ first2 >r dup dup r> 4array ] } + { 3 [ 1 suffix ] } + { 4 [ ] } } case ; -METHOD: set-color { rgba } - { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ; +METHOD: canonical-color-value { rgba } + { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: fill ( value -- ) >fill-color ; -: stroke ( value -- ) >stroke-color ; +: fill ( value -- ) canonical-color-value >fill-color ; +: stroke ( value -- ) canonical-color-value >stroke-color ; -: no-fill ( -- ) - fill-color> - { - { [ dup number? ] [ 0 2array fill ] } - { [ t ] - [ - [ drop 0 ] [ length 1- ] [ ] tri set-nth - ] } - } - cond ; - -: no-stroke ( -- ) - stroke-color> - { - { [ dup number? ] [ 0 2array stroke ] } - { [ t ] - [ - [ drop 0 ] [ length 1- ] [ ] tri set-nth - ] } - } - cond ; +: no-fill ( -- ) 0 fill-color> set-fourth ; +: no-stroke ( -- ) 0 stroke-color> set-fourth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -90,163 +72,163 @@ METHOD: set-color { rgba } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: point* ( x y -- ) - stroke-color> set-color - GL_POINTS glBegin - glVertex2d - glEnd ; +! : point* ( x y -- ) +! stroke-color> set-color +! GL_POINTS glBegin +! glVertex2d +! glEnd ; -: point ( seq -- ) first2 point* ; +! : point ( seq -- ) first2 point* ; -: line ( x1 y1 x2 y2 -- ) - stroke-color> set-color - GL_LINES glBegin - glVertex2d - glVertex2d - glEnd ; +! : line ( x1 y1 x2 y2 -- ) +! stroke-color> set-color +! GL_LINES glBegin +! glVertex2d +! glVertex2d +! glEnd ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: triangle ( x1 y1 x2 y2 x3 y3 -- ) +! : triangle ( x1 y1 x2 y2 x3 y3 -- ) - GL_FRONT_AND_BACK GL_FILL glPolygonMode - fill-color> set-color +! GL_FRONT_AND_BACK GL_FILL glPolygonMode +! fill-color> set-color - 6 ndup +! 6 ndup - GL_TRIANGLES glBegin - glVertex2d - glVertex2d - glVertex2d - glEnd +! GL_TRIANGLES glBegin +! glVertex2d +! glVertex2d +! glVertex2d +! glEnd - GL_FRONT_AND_BACK GL_LINE glPolygonMode - stroke-color> set-color +! GL_FRONT_AND_BACK GL_LINE glPolygonMode +! stroke-color> set-color - GL_TRIANGLES glBegin - glVertex2d - glVertex2d - glVertex2d - glEnd ; +! GL_TRIANGLES glBegin +! glVertex2d +! glVertex2d +! glVertex2d +! glEnd ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) - GL_POLYGON glBegin - glVertex2d - glVertex2d - glVertex2d - glVertex2d - glEnd ; +! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) +! GL_POLYGON glBegin +! glVertex2d +! glVertex2d +! glVertex2d +! glVertex2d +! glEnd ; -: quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) +! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) - 8 ndup +! 8 ndup - GL_FRONT_AND_BACK GL_FILL glPolygonMode - fill-color> set-color +! GL_FRONT_AND_BACK GL_FILL glPolygonMode +! fill-color> set-color - quad-vertices +! quad-vertices - GL_FRONT_AND_BACK GL_LINE glPolygonMode - stroke-color> set-color +! GL_FRONT_AND_BACK GL_LINE glPolygonMode +! stroke-color> set-color - quad-vertices ; +! quad-vertices ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: rect-vertices ( x y width height -- ) - GL_POLYGON glBegin - [ 2drop glVertex2d ] 4keep - [ drop swap >r + 1- r> glVertex2d ] 4keep - [ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep - [ nip + 1- glVertex2d ] 4keep - 4drop - glEnd ; +! : rect-vertices ( x y width height -- ) +! GL_POLYGON glBegin +! [ 2drop glVertex2d ] 4keep +! [ drop swap >r + 1- r> glVertex2d ] 4keep +! [ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep +! [ nip + 1- glVertex2d ] 4keep +! 4drop +! glEnd ; -: rect ( x y width height -- ) +! : rect ( x y width height -- ) - 4dup +! 4dup - GL_FRONT_AND_BACK GL_FILL glPolygonMode - fill-color> set-color +! GL_FRONT_AND_BACK GL_FILL glPolygonMode +! fill-color> set-color - rect-vertices +! rect-vertices - GL_FRONT_AND_BACK GL_LINE glPolygonMode - stroke-color> set-color +! GL_FRONT_AND_BACK GL_LINE glPolygonMode +! stroke-color> set-color - rect-vertices ; +! rect-vertices ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: ellipse-disk ( x y width height -- ) - glPushMatrix - >r >r - 0 glTranslated - r> r> 1 glScaled - gluNewQuadric - dup 0 0.5 20 1 gluDisk - gluDeleteQuadric - glPopMatrix ; +! : ellipse-disk ( x y width height -- ) +! glPushMatrix +! >r >r +! 0 glTranslated +! r> r> 1 glScaled +! gluNewQuadric +! dup 0 0.5 20 1 gluDisk +! gluDeleteQuadric +! glPopMatrix ; -: ellipse-center ( x y width height -- ) +! : ellipse-center ( x y width height -- ) - 4dup +! 4dup - GL_FRONT_AND_BACK GL_FILL glPolygonMode - stroke-color> set-color +! GL_FRONT_AND_BACK GL_FILL glPolygonMode +! stroke-color> set-color - ellipse-disk +! ellipse-disk - GL_FRONT_AND_BACK GL_FILL glPolygonMode - fill-color> set-color +! GL_FRONT_AND_BACK GL_FILL glPolygonMode +! fill-color> set-color - [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@ +! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@ - ellipse-disk ; +! ellipse-disk ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: CENTER -SYMBOL: RADIUS -SYMBOL: CORNER -SYMBOL: CORNERS +! SYMBOL: CENTER +! SYMBOL: RADIUS +! SYMBOL: CORNER +! SYMBOL: CORNERS -SYMBOL: ellipse-mode-value +! SYMBOL: ellipse-mode-value -: ellipse-mode ( val -- ) ellipse-mode-value set ; +! : ellipse-mode ( val -- ) ellipse-mode-value set ; -: ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ; +! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ; -: ellipse-corner ( x y width height -- ) - [ drop nip 2 / + ] 4keep - [ nip rot drop 2 / + ] 4keep - [ >r >r 2drop r> r> ] 4keep - 4drop - ellipse-center ; +! : ellipse-corner ( x y width height -- ) +! [ drop nip 2 / + ] 4keep +! [ nip rot drop 2 / + ] 4keep +! [ >r >r 2drop r> r> ] 4keep +! 4drop +! ellipse-center ; -: ellipse-corners ( x1 y1 x2 y2 -- ) - [ drop nip + 2 / ] 4keep - [ nip rot drop + 2 / ] 4keep - [ drop nip - abs 1+ ] 4keep - [ nip rot drop - abs 1+ ] 4keep - 4drop - ellipse-center ; +! : ellipse-corners ( x1 y1 x2 y2 -- ) +! [ drop nip + 2 / ] 4keep +! [ nip rot drop + 2 / ] 4keep +! [ drop nip - abs 1+ ] 4keep +! [ nip rot drop - abs 1+ ] 4keep +! 4drop +! ellipse-center ; -: ellipse ( a b c d -- ) - ellipse-mode-value get - { - { CENTER [ ellipse-center ] } - { RADIUS [ ellipse-radius ] } - { CORNER [ ellipse-corner ] } - { CORNERS [ ellipse-corners ] } - } - case ; +! : ellipse ( a b c d -- ) +! ellipse-mode-value get +! { +! { CENTER [ ellipse-center ] } +! { RADIUS [ ellipse-radius ] } +! { CORNER [ ellipse-corner ] } +! { CORNERS [ ellipse-corners ] } +! } +! case ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ; +! : circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -279,8 +261,8 @@ METHOD: background { array } : mouse ( -- point ) hand-loc get ; -: mouse-x mouse first ; -: mouse-y mouse second ; +: mouse-x ( -- x ) mouse first ; +: mouse-y ( -- y ) mouse second ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -296,9 +278,9 @@ VAR: loop-flag : defaults ( -- ) 0.8 background - 0 >stroke-color - 1 >fill-color - CENTER ellipse-mode + ! 0 >stroke-color + ! 1 >fill-color + ! CENTER ellipse-mode 60 frame-rate ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From fce11759e9e258843d11d7d170712e954d9ac58f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 12:54:47 -0500 Subject: [PATCH 20/65] processing.gallery.trails: Update for processing changes --- extra/processing/gallery/trails/trails.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor index 5abe23bb90..a5b2b7b02a 100644 --- a/extra/processing/gallery/trails/trails.factor +++ b/extra/processing/gallery/trails/trails.factor @@ -1,6 +1,6 @@ USING: kernel arrays sequences math math.order qualified - sequences.lib circular processing ui newfx ; + sequences.lib circular processing ui newfx processing.shapes ; IN: processing.gallery.trails From 72344abf718dc39a2c6404f6cf7d6d94ff797c87 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 12:55:08 -0500 Subject: [PATCH 21/65] bubble-chamber: Update for processing changes --- extra/bubble-chamber/particle/axion/axion.factor | 3 ++- extra/bubble-chamber/particle/hadron/hadron.factor | 2 +- extra/bubble-chamber/particle/muon/muon.factor | 1 + extra/bubble-chamber/particle/quark/quark.factor | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/bubble-chamber/particle/axion/axion.factor b/extra/bubble-chamber/particle/axion/axion.factor index 54865894c6..2dafc36cde 100644 --- a/extra/bubble-chamber/particle/axion/axion.factor +++ b/extra/bubble-chamber/particle/axion/axion.factor @@ -1,7 +1,8 @@ USING: kernel sequences random accessors multi-methods math math.constants math.ranges math.points combinators.cleave - processing bubble-chamber.common bubble-chamber.particle ; + processing processing.shapes + bubble-chamber.common bubble-chamber.particle ; IN: bubble-chamber.particle.axion diff --git a/extra/bubble-chamber/particle/hadron/hadron.factor b/extra/bubble-chamber/particle/hadron/hadron.factor index 9eecf2dd93..10a5431e57 100644 --- a/extra/bubble-chamber/particle/hadron/hadron.factor +++ b/extra/bubble-chamber/particle/hadron/hadron.factor @@ -1,6 +1,6 @@ USING: kernel random math math.constants math.points accessors multi-methods - processing + processing processing.shapes processing.color bubble-chamber.common bubble-chamber.particle ; diff --git a/extra/bubble-chamber/particle/muon/muon.factor b/extra/bubble-chamber/particle/muon/muon.factor index a61526fdf7..c5ee71c1b0 100644 --- a/extra/bubble-chamber/particle/muon/muon.factor +++ b/extra/bubble-chamber/particle/muon/muon.factor @@ -7,6 +7,7 @@ USING: kernel arrays sequences random multi-methods accessors combinators.cleave processing + processing.shapes bubble-chamber.common bubble-chamber.particle bubble-chamber.particle.muon.colors ; diff --git a/extra/bubble-chamber/particle/quark/quark.factor b/extra/bubble-chamber/particle/quark/quark.factor index 595c3b5329..194b97a9cd 100644 --- a/extra/bubble-chamber/particle/quark/quark.factor +++ b/extra/bubble-chamber/particle/quark/quark.factor @@ -1,6 +1,6 @@ USING: kernel arrays sequences random math accessors multi-methods - processing + processing processing.shapes bubble-chamber.common bubble-chamber.particle ; From e10507e9ad146c342aec1fabdb1b2c557389466d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 12:58:30 -0500 Subject: [PATCH 22/65] processing: Minor cleanups --- extra/processing/processing.factor | 81 ------------------------------ 1 file changed, 81 deletions(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index bcfe314d45..f365f80d78 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -37,11 +37,6 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! VAR: fill-color -! VAR: stroke-color - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - GENERIC: canonical-color-value ( obj -- color ) METHOD: canonical-color-value { number } dup dup 1 4array ; @@ -72,47 +67,6 @@ METHOD: canonical-color-value { rgba } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : point* ( x y -- ) -! stroke-color> set-color -! GL_POINTS glBegin -! glVertex2d -! glEnd ; - -! : point ( seq -- ) first2 point* ; - -! : line ( x1 y1 x2 y2 -- ) -! stroke-color> set-color -! GL_LINES glBegin -! glVertex2d -! glVertex2d -! glEnd ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! : triangle ( x1 y1 x2 y2 x3 y3 -- ) - -! GL_FRONT_AND_BACK GL_FILL glPolygonMode -! fill-color> set-color - -! 6 ndup - -! GL_TRIANGLES glBegin -! glVertex2d -! glVertex2d -! glVertex2d -! glEnd - -! GL_FRONT_AND_BACK GL_LINE glPolygonMode -! stroke-color> set-color - -! GL_TRIANGLES glBegin -! glVertex2d -! glVertex2d -! glVertex2d -! glEnd ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) ! GL_POLYGON glBegin ! glVertex2d @@ -137,31 +91,6 @@ METHOD: canonical-color-value { rgba } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : rect-vertices ( x y width height -- ) -! GL_POLYGON glBegin -! [ 2drop glVertex2d ] 4keep -! [ drop swap >r + 1- r> glVertex2d ] 4keep -! [ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep -! [ nip + 1- glVertex2d ] 4keep -! 4drop -! glEnd ; - -! : rect ( x y width height -- ) - -! 4dup - -! GL_FRONT_AND_BACK GL_FILL glPolygonMode -! fill-color> set-color - -! rect-vertices - -! GL_FRONT_AND_BACK GL_LINE glPolygonMode -! stroke-color> set-color - -! rect-vertices ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! : ellipse-disk ( x y width height -- ) ! glPushMatrix ! >r >r @@ -228,14 +157,6 @@ METHOD: canonical-color-value { rgba } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USING: multi-methods ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - GENERIC: background ( value -- ) METHOD: background { number } @@ -278,8 +199,6 @@ VAR: loop-flag : defaults ( -- ) 0.8 background - ! 0 >stroke-color - ! 1 >fill-color ! CENTER ellipse-mode 60 frame-rate ; From e9e1313b6cbdaa2e5edad6179136149b6a3eeb63 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 14:19:11 -0500 Subject: [PATCH 23/65] colors: Add color tuples --- extra/colors/colors.factor | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/extra/colors/colors.factor b/extra/colors/colors.factor index 911f3d0b59..f8de326b4d 100644 --- a/extra/colors/colors.factor +++ b/extra/colors/colors.factor @@ -1,7 +1,43 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. + +USING: kernel combinators sequences arrays + classes.tuple multi-methods accessors colors.hsv ; + IN: colors +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: color ; + +TUPLE: rgba < color red green blue alpha ; + +TUPLE: hsva < color hue saturation value alpha ; + +TUPLE: grey < color grey alpha ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: >rgba ( object -- rgba ) + +METHOD: >rgba { rgba } ; + +METHOD: >rgba { hsva } + { [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array + [ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ; + +METHOD: >rgba { grey } [ grey>> dup dup ] [ alpha>> ] bi rgba boa ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: syntax + +M: color red>> >rgba red>> ; +M: color green>> >rgba green>> ; +M: color blue>> >rgba blue>> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : black { 0.0 0.0 0.0 1.0 } ; : blue { 0.0 0.0 1.0 1.0 } ; : cyan { 0 0.941 0.941 1 } ; From 47d8a56dc01bbcd2cc0c5861f8060261001d9a1b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 14:19:35 -0500 Subject: [PATCH 24/65] opengl: Add words to work with color objects --- extra/opengl/opengl.factor | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index be70b1e176..3964288666 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -2,10 +2,12 @@ ! Portions copyright (C) 2007 Eduardo Cavazos. ! Portions copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. + USING: alien alien.c-types continuations kernel libc math macros -namespaces math.vectors math.constants math.functions -math.parser opengl.gl opengl.glu combinators arrays sequences -splitting words byte-arrays assocs ; + namespaces math.vectors math.constants math.functions + math.parser opengl.gl opengl.glu combinators arrays sequences + splitting words byte-arrays assocs colors accessors ; + IN: opengl : coordinates ( point1 point2 -- x1 y2 x2 y2 ) @@ -14,6 +16,8 @@ IN: opengl : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) [ first2 [ >fixnum ] bi@ ] bi@ ; + + : gl-color ( color -- ) first4 glColor4d ; inline : gl-clear-color ( color -- ) @@ -22,6 +26,16 @@ IN: opengl : gl-clear ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ; +: color>raw ( object -- 4array ) + >rgba + { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave + 4array ; + +: set-color ( object -- ) color>raw first4 glColor4d ; +: set-clear-color ( object -- ) color>raw first4 glClearColor ; + + + : gl-error ( -- ) glGetError dup zero? [ "GL error: " over gluErrorString append throw From 4f4edfee30ff29f54f0d13b627686cde165efc8f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 14:47:51 -0500 Subject: [PATCH 25/65] opengl: color>raw word --- extra/opengl/opengl.factor | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 3964288666..6e6302b305 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -16,7 +16,7 @@ IN: opengl : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) [ first2 [ >fixnum ] bi@ ] bi@ ; - +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : gl-color ( color -- ) first4 glColor4d ; inline @@ -26,15 +26,13 @@ IN: opengl : gl-clear ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ; -: color>raw ( object -- 4array ) - >rgba - { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave - 4array ; - -: set-color ( object -- ) color>raw first4 glColor4d ; -: set-clear-color ( object -- ) color>raw first4 glClearColor ; +: color>raw ( object -- r g b a ) + >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; +: set-color ( object -- ) color>raw glColor4d ; +: set-clear-color ( object -- ) color>raw glClearColor ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : gl-error ( -- ) glGetError dup zero? [ From 19feaebb19b615083cdc8bd6bb43b29700a539ea Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 14:49:20 -0500 Subject: [PATCH 26/65] processing.shapes: use color objects --- extra/processing/shapes/shapes.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/processing/shapes/shapes.factor b/extra/processing/shapes/shapes.factor index 16530c5414..d92da8c869 100644 --- a/extra/processing/shapes/shapes.factor +++ b/extra/processing/shapes/shapes.factor @@ -3,7 +3,7 @@ USING: kernel namespaces arrays sequences grouping alien.c-types math math.vectors math.geometry.rect opengl.gl opengl.glu opengl generalizations vars - combinators.cleave ; + combinators.cleave colors ; IN: processing.shapes @@ -12,20 +12,20 @@ IN: processing.shapes VAR: fill-color VAR: stroke-color -{ 0 0 0 1 } stroke-color set-global -{ 1 1 1 1 } fill-color set-global +T{ rgba f 0 0 0 1 } stroke-color set-global +T{ rgba f 1 1 1 1 } fill-color set-global ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : fill-mode ( -- ) GL_FRONT_AND_BACK GL_FILL glPolygonMode - fill-color> gl-color ; + fill-color> set-color ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : stroke-mode ( -- ) GL_FRONT_AND_BACK GL_LINE glPolygonMode - stroke-color> gl-color ; + stroke-color> set-color ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -101,8 +101,8 @@ VAR: stroke-color : ellipse ( center dim -- ) GL_FRONT_AND_BACK GL_FILL glPolygonMode - [ stroke-color> gl-color gl-ellipse ] - [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ; + [ stroke-color> set-color gl-ellipse ] + [ fill-color> set-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 1324f6e096380a6a57dec15938918a5e7ffeadb2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 14:49:41 -0500 Subject: [PATCH 27/65] processing: use color objects --- extra/processing/processing.factor | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index f365f80d78..07b92fa8fd 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -9,9 +9,9 @@ USING: kernel namespaces threads combinators sequences arrays combinators.lib combinators.cleave rewrite-closures fry accessors newfx - processing.color processing.gadget math.geometry.rect - processing.shapes ; + processing.shapes + colors ; IN: processing @@ -39,27 +39,32 @@ IN: processing GENERIC: canonical-color-value ( obj -- color ) -METHOD: canonical-color-value { number } dup dup 1 4array ; +METHOD: canonical-color-value { number } dup dup 1 rgba boa ; METHOD: canonical-color-value { array } dup length { - { 2 [ first2 >r dup dup r> 4array ] } - { 3 [ 1 suffix ] } - { 4 [ ] } + { 2 [ first2 >r dup dup r> rgba boa ] } + { 3 [ first3 1 rgba boa ] } + { 4 [ first4 rgba boa ] } } case ; -METHOD: canonical-color-value { rgba } - { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ; +! METHOD: canonical-color-value { rgba } +! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ; + +METHOD: canonical-color-value { color } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : fill ( value -- ) canonical-color-value >fill-color ; : stroke ( value -- ) canonical-color-value >stroke-color ; -: no-fill ( -- ) 0 fill-color> set-fourth ; -: no-stroke ( -- ) 0 stroke-color> set-fourth ; +! : no-fill ( -- ) 0 fill-color> set-fourth ; +! : no-stroke ( -- ) 0 stroke-color> set-fourth ; + +: no-fill ( -- ) fill-color> 0 >>alpha drop ; +: no-stroke ( -- ) stroke-color> 0 >>alpha drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 4c9c8ede6fbc3b5f396f0c67137de79133f30bf1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 14:49:54 -0500 Subject: [PATCH 28/65] bubble-chamber: use color objects --- extra/bubble-chamber/particle/hadron/hadron.factor | 5 ++--- extra/bubble-chamber/particle/muon/colors/colors.factor | 2 +- extra/bubble-chamber/particle/particle.factor | 8 ++++---- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/extra/bubble-chamber/particle/hadron/hadron.factor b/extra/bubble-chamber/particle/hadron/hadron.factor index 10a5431e57..910df97789 100644 --- a/extra/bubble-chamber/particle/hadron/hadron.factor +++ b/extra/bubble-chamber/particle/hadron/hadron.factor @@ -1,9 +1,8 @@ USING: kernel random math math.constants math.points accessors multi-methods processing processing.shapes - processing.color bubble-chamber.common - bubble-chamber.particle ; + bubble-chamber.particle colors ; IN: bubble-chamber.particle.hadron @@ -26,7 +25,7 @@ METHOD: collide { hadron } [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while - 0 1 0 >>myc + 0 1 0 1 rgba boa >>myc drop ; diff --git a/extra/bubble-chamber/particle/muon/colors/colors.factor b/extra/bubble-chamber/particle/muon/colors/colors.factor index e68fff5efd..644bed833b 100644 --- a/extra/bubble-chamber/particle/muon/colors/colors.factor +++ b/extra/bubble-chamber/particle/muon/colors/colors.factor @@ -1,7 +1,7 @@ USING: kernel sequences math math.constants math.order accessors processing - processing.color ; + colors ; IN: bubble-chamber.particle.muon.colors diff --git a/extra/bubble-chamber/particle/particle.factor b/extra/bubble-chamber/particle/particle.factor index 755a414b71..8b13e9b4b7 100644 --- a/extra/bubble-chamber/particle/particle.factor +++ b/extra/bubble-chamber/particle/particle.factor @@ -1,8 +1,8 @@ USING: kernel sequences combinators math math.vectors math.functions multi-methods - accessors combinators.cleave processing processing.color - bubble-chamber.common ; + accessors combinators.cleave processing + bubble-chamber.common colors ; IN: bubble-chamber.particle @@ -28,8 +28,8 @@ TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ; 0 >>theta-d 0 >>theta-dd - 0 0 0 1 >>myc - 0 0 0 1 >>mya ; + 0 0 0 1 rgba boa >>myc + 0 0 0 1 rgba boa >>mya ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 4e8ac9d7be361774018c159fc9b277d5f93df44a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 14:59:29 -0500 Subject: [PATCH 29/65] golden-section: use color objects --- extra/golden-section/golden-section.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/golden-section/golden-section.factor b/extra/golden-section/golden-section.factor index a83dc988fd..807ef1355a 100644 --- a/extra/golden-section/golden-section.factor +++ b/extra/golden-section/golden-section.factor @@ -27,7 +27,7 @@ IN: golden-section : radius ( i -- radius ) pi * 720 / sin 10 * ; -: color ( i -- i ) dup 360.0 / dup 0.25 1 4array >fill-color ; +: color ( i -- i ) dup 360.0 / dup 0.25 1 rgba boa >fill-color ; : line-width ( i -- i ) dup radius 0.5 * 1 max glLineWidth ; From 86d2cd4066776e0177687f1d5e47be037f53c2a9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 14:59:40 -0500 Subject: [PATCH 30/65] boids.ui: use color objects --- extra/boids/ui/ui.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index 38dd9b4f78..cd73c67a71 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -41,7 +41,7 @@ IN: boids.ui : draw-boids ( -- ) boids> [ draw-boid ] each ; -: boid-color ( -- color ) { 1.0 0 0 0.3 } ; +: boid-color ( -- color ) T{ rgba f 1.0 0 0 0.3 } ; : display ( -- ) boid-color >fill-color From 2216486578242873e32cce400d96239d24a2e7d8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 16:59:05 -0500 Subject: [PATCH 31/65] colors: Basic colors are now objects. Add the >rgba method on arrays (kludge). --- extra/colors/colors.factor | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/extra/colors/colors.factor b/extra/colors/colors.factor index f8de326b4d..02ad3ac778 100644 --- a/extra/colors/colors.factor +++ b/extra/colors/colors.factor @@ -28,6 +28,8 @@ METHOD: >rgba { hsva } METHOD: >rgba { grey } [ grey>> dup dup ] [ alpha>> ] bi rgba boa ; +METHOD: >rgba { array } first4 rgba boa ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! USE: syntax @@ -38,16 +40,16 @@ M: color blue>> >rgba blue>> ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: black { 0.0 0.0 0.0 1.0 } ; -: blue { 0.0 0.0 1.0 1.0 } ; -: cyan { 0 0.941 0.941 1 } ; -: gray { 0.6 0.6 0.6 1.0 } ; -: green { 0.0 1.0 0.0 1.0 } ; -: light-gray { 0.95 0.95 0.95 0.95 } ; -: light-purple { 0.8 0.8 1.0 1.0 } ; -: magenta { 0.941 0 0.941 1 } ; -: orange { 0.941 0.627 0 1 } ; -: purple { 0.627 0 0.941 1 } ; -: red { 1.0 0.0 0.0 1.0 } ; -: white { 1.0 1.0 1.0 1.0 } ; -: yellow { 1.0 1.0 0.0 1.0 } ; +: black T{ rgba f 0.0 0.0 0.0 1.0 } ; +: blue T{ rgba f 0.0 0.0 1.0 1.0 } ; +: cyan T{ rgba f 0 0.941 0.941 1 } ; +: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; +: green T{ rgba f 0.0 1.0 0.0 1.0 } ; +: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; +: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; +: magenta T{ rgba f 0.941 0 0.941 1 } ; +: orange T{ rgba f 0.941 0.627 0 1 } ; +: purple T{ rgba f 0.627 0 0.941 1 } ; +: red T{ rgba f 1.0 0.0 0.0 1.0 } ; +: white T{ rgba f 1.0 1.0 1.0 1.0 } ; +: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; From 57f8f811b938da2cbcf3a7e264f75818b851e965 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 17:00:30 -0500 Subject: [PATCH 32/65] opengl: Change gl-gradient to handle color objects --- extra/opengl/opengl.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 6e6302b305..29c2e5400a 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -124,7 +124,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) GL_QUAD_STRIP [ swap >r prepare-gradient r> [ length dup 1- v/n ] keep [ - >r >r 2dup r> r> gl-color v*n + >r >r 2dup r> r> set-color v*n dup gl-vertex v+ gl-vertex ] 2each 2drop ] do-state ; From 4643501ba6f79986a96f940eef6a2784e43be0d6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 17:01:08 -0500 Subject: [PATCH 33/65] slides: Update for color objects --- extra/slides/slides.factor | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index e73da15296..c3c105143e 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -23,14 +23,14 @@ IN: slides H{ { font "monospace" } { font-size 36 } - { page-color { 0.4 0.4 0.4 0.3 } } + { page-color T{ rgba f 0.4 0.4 0.4 0.3 } } } } { snippet-style H{ { font "monospace" } { font-size 36 } - { foreground { 0.1 0.1 0.4 1 } } + { foreground T{ rgba f 0.1 0.1 0.4 1 } } } } { table-content-style @@ -48,14 +48,19 @@ IN: slides : $divider ( -- ) [ - T{ gradient f { { 0.25 0.25 0.25 1.0 } { 1.0 1.0 1.0 0.0 } } } >>interior + T{ gradient f + { + T{ rgba f 0.25 0.25 0.25 1.0 } + T{ rgba f 1.0 1.0 1.0 0.0 } + } + } >>interior { 800 10 } >>dim { 1 0 } >>orientation gadget. ] ($block) ; : page-theme ( gadget -- ) - T{ gradient f { { 0.8 0.8 1.0 1.0 } { 0.8 1.0 1.0 1.0 } } } + T{ gradient f { T{ rgba f 0.8 0.8 1.0 1.0 } T{ rgba f 0.8 1.0 1.0 1.0 } } } swap set-gadget-interior ; : ( list -- gadget ) From 20ee2dd2a7951f621647d4b5043cdb1c89c5fbf3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 28 Jul 2008 17:01:24 -0500 Subject: [PATCH 34/65] Update lot's of ui vocabularies for color objects --- extra/ui/gadgets/buttons/buttons.factor | 6 +-- extra/ui/gadgets/editors/editors.factor | 6 +-- extra/ui/gadgets/grid-lines/grid-lines.factor | 2 +- extra/ui/gadgets/labelled/labelled.factor | 4 +- extra/ui/gadgets/labels/labels.factor | 2 +- extra/ui/gadgets/lists/lists.factor | 7 ++-- extra/ui/gadgets/panes/panes.factor | 2 +- extra/ui/gadgets/theme/theme.factor | 38 +++++++++---------- extra/ui/render/render.factor | 6 +-- 9 files changed, 37 insertions(+), 36 deletions(-) diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index e9475495bf..c5a5e8bad8 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -106,7 +106,7 @@ TUPLE: checkmark-paint color ; C: checkmark-paint M: checkmark-paint draw-interior - checkmark-paint-color gl-color + checkmark-paint-color set-color origin get [ rect-dim { 0 0 } over gl-line @@ -152,11 +152,11 @@ TUPLE: radio-paint color ; C: radio-paint M: radio-paint draw-interior - radio-paint-color gl-color + radio-paint-color set-color origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ; M: radio-paint draw-boundary - radio-paint-color gl-color + radio-paint-color set-color origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ; : radio-knob-theme ( gadget -- ) diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 8b0244900a..301121cdcc 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -129,7 +129,7 @@ M: editor ungraft* : draw-caret ( -- ) editor get editor-focused? [ editor get - dup editor-caret-color gl-color + dup editor-caret-color set-color dup caret-loc origin get v+ swap caret-dim over v+ [ { 0.5 -0.5 } v+ ] bi@ gl-line @@ -173,7 +173,7 @@ M: editor ungraft* : draw-lines ( -- ) \ first-visible-line get [ - editor get dup editor-color gl-color + editor get dup editor-color set-color dup visible-lines [ draw-line 1 translate-lines ] with each ] with-editor-translation ; @@ -192,7 +192,7 @@ M: editor ungraft* (draw-selection) ; : draw-selection ( -- ) - editor get editor-selection-color gl-color + editor get editor-selection-color set-color editor get selection-start/end over first [ 2dup [ diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor index d0cedc985b..3f08425e95 100755 --- a/extra/ui/gadgets/grid-lines/grid-lines.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines.factor @@ -25,7 +25,7 @@ SYMBOL: grid-dim M: grid-lines draw-boundary origin get [ -0.5 -0.5 0.0 glTranslated - grid-lines-color gl-color [ + grid-lines-color set-color [ dup grid set dup rect-dim half-gap v- grid-dim set compute-grid diff --git a/extra/ui/gadgets/labelled/labelled.factor b/extra/ui/gadgets/labelled/labelled.factor index bd775a2d39..dd5b1124e1 100755 --- a/extra/ui/gadgets/labelled/labelled.factor +++ b/extra/ui/gadgets/labelled/labelled.factor @@ -31,8 +31,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ; : title-theme ( gadget -- ) { 1 0 } over set-gadget-orientation T{ gradient f { - { 0.65 0.65 1.0 1.0 } - { 0.65 0.45 1.0 1.0 } + T{ rgba f 0.65 0.65 1.0 1.0 } + T{ rgba f 0.65 0.45 1.0 1.0 } } } swap set-gadget-interior ; : ( text -- label )