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