From 972619f50f531de609dfd4bb8e7aaf498b46eba5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Jul 2008 23:50:21 -0500 Subject: [PATCH] Working on sparse conditional constant propagation and untupling --- .../compiler/frontend/frontend-tests.factor | 6 - unfinished/compiler/frontend/frontend.factor | 79 --------- .../builder/builder-docs.factor} | 10 +- .../tree/builder/builder-tests.factor | 6 + .../compiler/tree/builder/builder.factor | 99 ++++++++--- unfinished/compiler/tree/co | 1 + .../tree/combinators/combinators-tests.factor | 6 +- .../tree/combinators/combinators.factor | 26 +-- .../tree/comparisons/comparisons.factor | 50 ++++++ .../tree/copy-equiv/copy-equiv.factor | 42 +++++ .../tree/dead-code/dead-code-tests.factor | 4 +- .../compiler/tree/dead-code/dead-code.factor | 166 ++++++------------ .../tree/def-use/def-use-tests.factor | 6 +- .../compiler/tree/def-use/def-use.factor | 2 + .../tree/dfa/backward/backward.factor | 40 +++++ unfinished/compiler/tree/dfa/dfa.factor | 40 +++++ .../tree/propagation/branches/branches.factor | 37 +++- .../constraints/constraints.factor | 56 ++++-- .../tree/propagation/info/info-tests.factor | 4 +- .../tree/propagation/info/info.factor | 58 +++--- .../known-words/known-words.factor | 77 ++++---- .../tree/propagation/nodes/nodes.factor | 5 +- .../tree/propagation/propagation-tests.factor | 62 ++++++- .../tree/propagation/propagation.factor | 2 - .../propagation/recursive/recursive.factor | 12 +- .../tree/propagation/simple/simple.factor | 59 ++++--- unfinished/compiler/tree/tree.factor | 47 +++-- .../tree/untupling/untupling-tests.factor | 50 ++++++ .../compiler/tree/untupling/untupling.factor | 59 +++++++ .../stack-checker/backend/backend.factor | 6 +- .../stack-checker/branches/branches.factor | 2 +- .../stack-checker/inlining/inlining.factor | 2 +- .../known-words/known-words.factor | 2 +- .../stack-checker/visitor/dummy/dummy.factor | 2 +- .../stack-checker/visitor/visitor.factor | 38 ++-- 35 files changed, 732 insertions(+), 431 deletions(-) delete mode 100644 unfinished/compiler/frontend/frontend-tests.factor delete mode 100644 unfinished/compiler/frontend/frontend.factor rename unfinished/compiler/{frontend/frontend-docs.factor => tree/builder/builder-docs.factor} (90%) create mode 100644 unfinished/compiler/tree/builder/builder-tests.factor create mode 100644 unfinished/compiler/tree/co create mode 100644 unfinished/compiler/tree/comparisons/comparisons.factor create mode 100644 unfinished/compiler/tree/copy-equiv/copy-equiv.factor create mode 100644 unfinished/compiler/tree/dfa/backward/backward.factor create mode 100644 unfinished/compiler/tree/dfa/dfa.factor create mode 100644 unfinished/compiler/tree/untupling/untupling-tests.factor create mode 100644 unfinished/compiler/tree/untupling/untupling.factor diff --git a/unfinished/compiler/frontend/frontend-tests.factor b/unfinished/compiler/frontend/frontend-tests.factor deleted file mode 100644 index 9e254b2a1e..0000000000 --- a/unfinished/compiler/frontend/frontend-tests.factor +++ /dev/null @@ -1,6 +0,0 @@ -IN: compiler.frontend.tests -USING: compiler.frontend tools.test ; - -\ dataflow must-infer -\ dataflow-with must-infer -\ word-dataflow must-infer diff --git a/unfinished/compiler/frontend/frontend.factor b/unfinished/compiler/frontend/frontend.factor deleted file mode 100644 index f9f93d160a..0000000000 --- a/unfinished/compiler/frontend/frontend.factor +++ /dev/null @@ -1,79 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors quotations kernel sequences namespaces assocs -words generic generic.standard generic.standard.engines arrays -kernel.private combinators vectors stack-checker -stack-checker.state stack-checker.visitor stack-checker.errors -stack-checker.backend compiler.tree.builder ; -IN: compiler.frontend - -: with-dataflow ( quot -- dataflow ) - [ tree-builder new dataflow-visitor set ] prepose - with-infer first>> ; inline - -GENERIC# dataflow-with 1 ( quot stack -- dataflow ) - -M: callable dataflow-with - #! Not safe to call from inference transforms. - [ - >vector meta-d set - f infer-quot - ] with-dataflow nip ; - -: dataflow ( quot -- dataflow ) f dataflow-with ; - -: (make-specializer) ( class picker -- quot ) - swap "predicate" word-prop append ; - -: make-specializer ( classes -- quot ) - dup length - [ (picker) 2array ] 2map - [ drop object eq? not ] assoc-filter - dup empty? [ drop [ t ] ] [ - [ (make-specializer) ] { } assoc>map - unclip [ swap [ f ] \ if 3array append [ ] like ] reduce - ] if ; - -: specializer-cases ( quot word -- default alist ) - dup [ array? ] all? [ 1array ] unless [ - [ make-specializer ] keep - '[ , declare ] pick append - ] { } map>assoc ; - -: method-declaration ( method -- quot ) - dup "method-generic" word-prop dispatch# object - swap "method-class" word-prop prefix ; - -: specialize-method ( quot method -- quot' ) - method-declaration '[ , declare ] prepend ; - -: specialize-quot ( quot specializer -- quot' ) - specializer-cases alist>quot ; - -: standard-method? ( method -- ? ) - dup method-body? [ - "method-generic" word-prop standard-generic? - ] [ drop f ] if ; - -: specialized-def ( word -- quot ) - dup def>> swap { - { [ dup standard-method? ] [ specialize-method ] } - { - [ dup "specializer" word-prop ] - [ "specializer" word-prop specialize-quot ] - } - [ drop ] - } cond ; - -: word-dataflow ( word -- effect dataflow ) - [ - [ - dup +cannot-infer+ word-prop [ cannot-infer-effect ] when - dup "no-compile" word-prop [ cannot-infer-effect ] when - dup specialized-def over dup 2array 1array infer-quot - finish-word - ] maybe-cannot-infer - ] with-dataflow ; - -: specialized-length ( specializer -- n ) - dup [ array? ] all? [ first ] when length ; diff --git a/unfinished/compiler/frontend/frontend-docs.factor b/unfinished/compiler/tree/builder/builder-docs.factor similarity index 90% rename from unfinished/compiler/frontend/frontend-docs.factor rename to unfinished/compiler/tree/builder/builder-docs.factor index 294ac4a905..77b6193f8f 100644 --- a/unfinished/compiler/frontend/frontend-docs.factor +++ b/unfinished/compiler/tree/builder/builder-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax sequences quotations words compiler.tree stack-checker.errors ; -IN: compiler.frontend +IN: compiler.tree.builder ARTICLE: "specializers" "Word specializers" "The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class." @@ -22,15 +22,15 @@ $nl "The specialized version of a word which will be compiled by the compiler can be inspected:" { $subsection specialized-def } ; -HELP: dataflow +HELP: build-tree { $values { "quot" quotation } { "dataflow" node } } -{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." } +{ $description "Attempts to construct tree SSA IR from a quotation." } { $notes "This is the first stage of the compiler." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; -HELP: dataflow-with +HELP: build-tree-with { $values { "quot" quotation } { "stack" sequence } { "dataflow" node } } -{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." } +{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; HELP: specialized-def diff --git a/unfinished/compiler/tree/builder/builder-tests.factor b/unfinished/compiler/tree/builder/builder-tests.factor new file mode 100644 index 0000000000..1d859ac531 --- /dev/null +++ b/unfinished/compiler/tree/builder/builder-tests.factor @@ -0,0 +1,6 @@ +IN: compiler.tree.builder.tests +USING: compiler.tree.builder tools.test ; + +\ build-tree must-infer +\ build-tree-with must-infer +\ build-tree-from-word must-infer diff --git a/unfinished/compiler/tree/builder/builder.factor b/unfinished/compiler/tree/builder/builder.factor index f4f46c9fd9..79a2786f64 100644 --- a/unfinished/compiler/tree/builder/builder.factor +++ b/unfinished/compiler/tree/builder/builder.factor @@ -1,32 +1,79 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces kernel sequences compiler.tree -stack-checker.visitor ; +USING: fry accessors quotations kernel sequences namespaces assocs +words generic generic.standard generic.standard.engines arrays +kernel.private combinators vectors stack-checker +stack-checker.state stack-checker.visitor stack-checker.errors +stack-checker.backend compiler.tree ; IN: compiler.tree.builder -TUPLE: tree-builder first last ; +: with-tree-builder ( quot -- dataflow ) + [ node-list new stack-visitor set ] prepose + with-infer first>> ; inline -: node, ( node -- ) - dataflow-visitor get swap - over last>> - [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ] - [ [ >>first ] [ >>last ] bi drop ] - if ; +GENERIC# build-tree-with 1 ( quot stack -- dataflow ) -M: tree-builder child-visitor tree-builder new ; -M: tree-builder #introduce, #introduce node, ; -M: tree-builder #call, #call node, ; -M: tree-builder #call-recursive, #call-recursive node, ; -M: tree-builder #push, #push node, ; -M: tree-builder #shuffle, #shuffle node, ; -M: tree-builder #drop, #drop node, ; -M: tree-builder #>r, #>r node, ; -M: tree-builder #r>, #r> node, ; -M: tree-builder #return, #return node, ; -M: tree-builder #terminate, #terminate node, ; -M: tree-builder #if, [ first>> ] bi@ #if node, ; -M: tree-builder #dispatch, [ first>> ] map #dispatch node, ; -M: tree-builder #phi, #phi node, ; -M: tree-builder #declare, #declare node, ; -M: tree-builder #recursive, first>> #recursive node, ; -M: tree-builder #copy, #copy node, ; +M: callable build-tree-with + #! Not safe to call from inference transforms. + [ + >vector meta-d set + f infer-quot + ] with-tree-builder nip ; + +: build-tree ( quot -- dataflow ) f build-tree-with ; + +: (make-specializer) ( class picker -- quot ) + swap "predicate" word-prop append ; + +: make-specializer ( classes -- quot ) + dup length + [ (picker) 2array ] 2map + [ drop object eq? not ] assoc-filter + dup empty? [ drop [ t ] ] [ + [ (make-specializer) ] { } assoc>map + unclip [ swap [ f ] \ if 3array append [ ] like ] reduce + ] if ; + +: specializer-cases ( quot word -- default alist ) + dup [ array? ] all? [ 1array ] unless [ + [ make-specializer ] keep + '[ , declare ] pick append + ] { } map>assoc ; + +: method-declaration ( method -- quot ) + dup "method-generic" word-prop dispatch# object + swap "method-class" word-prop prefix ; + +: specialize-method ( quot method -- quot' ) + method-declaration '[ , declare ] prepend ; + +: specialize-quot ( quot specializer -- quot' ) + specializer-cases alist>quot ; + +: standard-method? ( method -- ? ) + dup method-body? [ + "method-generic" word-prop standard-generic? + ] [ drop f ] if ; + +: specialized-def ( word -- quot ) + dup def>> swap { + { [ dup standard-method? ] [ specialize-method ] } + { + [ dup "specializer" word-prop ] + [ "specializer" word-prop specialize-quot ] + } + [ drop ] + } cond ; + +: build-tree-from-word ( word -- effect dataflow ) + [ + [ + dup +cannot-infer+ word-prop [ cannot-infer-effect ] when + dup "no-compile" word-prop [ cannot-infer-effect ] when + dup specialized-def over dup 2array 1array infer-quot + finish-word + ] maybe-cannot-infer + ] with-tree-builder ; + +: specialized-length ( specializer -- n ) + dup [ array? ] all? [ first ] when length ; diff --git a/unfinished/compiler/tree/co b/unfinished/compiler/tree/co new file mode 100644 index 0000000000..8b13789179 --- /dev/null +++ b/unfinished/compiler/tree/co @@ -0,0 +1 @@ + diff --git a/unfinished/compiler/tree/combinators/combinators-tests.factor b/unfinished/compiler/tree/combinators/combinators-tests.factor index d81af543e1..15c07635ad 100644 --- a/unfinished/compiler/tree/combinators/combinators-tests.factor +++ b/unfinished/compiler/tree/combinators/combinators-tests.factor @@ -1,9 +1,9 @@ IN: compiler.tree.combinators.tests -USING: compiler.tree.combinators compiler.frontend tools.test +USING: compiler.tree.combinators compiler.tree.builder tools.test kernel ; -[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test -[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test +[ ] [ [ 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 diff --git a/unfinished/compiler/tree/combinators/combinators.factor b/unfinished/compiler/tree/combinators/combinators.factor index 95373c6e81..1f626163e5 100644 --- a/unfinished/compiler/tree/combinators/combinators.factor +++ b/unfinished/compiler/tree/combinators/combinators.factor @@ -5,18 +5,6 @@ sequences words vectors math.intervals effects classes accessors combinators compiler.tree ; IN: compiler.tree.combinators -: node-exists? ( node quot -- ? ) - over [ - 2dup 2slip rot [ - 2drop t - ] [ - [ [ children>> ] [ successor>> ] bi suffix ] dip - '[ , node-exists? ] contains? - ] if - ] [ - 2drop f - ] if ; inline - SYMBOL: node-stack : >node ( node -- ) node-stack get push ; @@ -34,8 +22,8 @@ SYMBOL: node-stack : (each-node) ( quot -- next ) node@ [ swap call ] 2keep - node-children [ - [ + children>> [ + first>> [ [ (each-node) ] keep swap ] iterate-nodes ] each drop @@ -52,15 +40,7 @@ SYMBOL: node-stack ] with-node-iterator ; inline : map-children ( node quot -- ) - over [ - over children>> [ - '[ , map ] change-children drop - ] [ - 2drop - ] if - ] [ - 2drop - ] if ; inline + [ children>> ] dip '[ , change-first drop ] each ; inline : (transform-nodes) ( prev node quot -- ) dup >r call dup [ diff --git a/unfinished/compiler/tree/comparisons/comparisons.factor b/unfinished/compiler/tree/comparisons/comparisons.factor new file mode 100644 index 0000000000..5242302411 --- /dev/null +++ b/unfinished/compiler/tree/comparisons/comparisons.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math math.order math.intervals assocs combinators ; +IN: compiler.tree.comparisons + +! Some utilities for working with comparison operations. + +: comparison-ops { < > <= >= } ; + +: generic-comparison-ops { before? after? before=? after=? } ; + +: assumption ( i1 i2 op -- i3 ) + { + { \ < [ assume< ] } + { \ > [ assume> ] } + { \ <= [ assume<= ] } + { \ >= [ assume>= ] } + } case ; + +: interval-comparison ( i1 i2 op -- result ) + { + { \ < [ interval< ] } + { \ > [ interval> ] } + { \ <= [ interval<= ] } + { \ >= [ interval>= ] } + } case ; + +: swap-comparison ( op -- op' ) + { + { < > } + { > < } + { <= >= } + { >= <= } + } at ; + +: negate-comparison ( op -- op' ) + { + { < >= } + { > <= } + { <= > } + { >= < } + } at ; + +: specific-comparison ( op -- op' ) + { + { before? < } + { after? > } + { before=? <= } + { after=? >= } + } at ; diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor new file mode 100644 index 0000000000..e3a2779376 --- /dev/null +++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces disjoint-sets sequences assocs +kernel accessors fry +compiler.tree compiler.tree.def-use compiler.tree.combinators ; +IN: compiler.tree.copy-equiv + +! Disjoint set of copy equivalence +SYMBOL: copies + +: is-copy-of ( val copy -- ) copies get equate ; + +: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ; + +: resolve-copy ( copy -- val ) copies get representative ; + +: introduce-value ( val -- ) copies get add-atom ; + +GENERIC: compute-copy-equiv* ( node -- ) + +M: #shuffle compute-copy-equiv* + [ out-d>> dup ] [ mapping>> ] bi + '[ , at ] map swap are-copies-of ; + +M: #>r compute-copy-equiv* + [ in-d>> ] [ out-r>> ] bi are-copies-of ; + +M: #r> compute-copy-equiv* + [ in-r>> ] [ out-d>> ] bi are-copies-of ; + +M: #copy compute-copy-equiv* + [ in-d>> ] [ out-d>> ] bi are-copies-of ; + +M: node compute-copy-equiv* drop ; + +: compute-copy-equiv ( node -- node ) + copies set + dup [ + [ node-defs-values [ introduce-value ] each ] + [ compute-copy-equiv* ] + bi + ] each-node ; diff --git a/unfinished/compiler/tree/dead-code/dead-code-tests.factor b/unfinished/compiler/tree/dead-code/dead-code-tests.factor index 503c459fae..51a34bcd50 100644 --- a/unfinished/compiler/tree/dead-code/dead-code-tests.factor +++ b/unfinished/compiler/tree/dead-code/dead-code-tests.factor @@ -1,4 +1,4 @@ -USING: namespaces assocs sequences compiler.frontend +USING: namespaces assocs sequences compiler.tree.builder compiler.tree.dead-code compiler.tree.def-use compiler.tree compiler.tree.combinators tools.test kernel math stack-checker.state accessors ; @@ -7,7 +7,7 @@ IN: compiler.tree.dead-code.tests \ remove-dead-code must-infer : count-live-values ( quot -- n ) - dataflow + build-tree compute-def-use remove-dead-code compute-def-use diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor index 4ad61afd19..365a0bdd45 100644 --- a/unfinished/compiler/tree/dead-code/dead-code.factor +++ b/unfinished/compiler/tree/dead-code/dead-code.factor @@ -1,106 +1,44 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors namespaces assocs dequeues search-dequeues -kernel sequences words sets stack-checker.inlining compiler.tree -compiler.tree.combinators compiler.tree.def-use ; +kernel sequences words sets stack-checker.inlining +compiler.tree +compiler.tree.dfa +compiler.tree.dfa.backward +compiler.tree.combinators ; IN: compiler.tree.dead-code ! Dead code elimination: remove #push and flushable #call whose -! outputs are unused. - -SYMBOL: live-values -SYMBOL: work-list - -: live-value? ( value -- ? ) - live-values get at ; - -: look-at-value ( values -- ) - work-list get push-front ; - -: look-at-values ( values -- ) - work-list get '[ , push-front ] each ; - +! outputs are unused using backward DFA. GENERIC: mark-live-values ( node -- ) -: look-at-inputs ( node -- ) in-d>> look-at-values ; - -: look-at-outputs ( node -- ) out-d>> look-at-values ; - -M: #introduce mark-live-values look-at-outputs ; - M: #if mark-live-values look-at-inputs ; M: #dispatch mark-live-values look-at-inputs ; M: #call mark-live-values - dup word>> "flushable" word-prop [ drop ] [ - [ look-at-inputs ] - [ look-at-outputs ] - bi - ] if ; + dup word>> "flushable" word-prop + [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ; M: #return mark-live-values #! Values returned by local #recursive functions can be #! killed if they're unused. - dup label>> - [ drop ] [ look-at-inputs ] if ; + dup label>> [ drop ] [ look-at-inputs ] if ; M: node mark-live-values drop ; -GENERIC: propagate* ( value node -- ) +SYMBOL: live-values -M: #copy propagate* - #! If the output of a copy is live, then the corresponding - #! input is live also. - [ out-d>> index ] keep in-d>> nth look-at-value ; - -M: #call propagate* - #! If any of the outputs of a call are live, then all - #! inputs and outputs must be live. - nip [ look-at-inputs ] [ look-at-outputs ] bi ; - -M: #call-recursive propagate* - #! If the output of a copy is live, then the corresponding - #! inputs to #return nodes are live also. - [ out-d>> index ] keep label>> returns>> - [ nth look-at-value ] with each ; - -M: #>r propagate* nip in-d>> first look-at-value ; - -M: #r> propagate* nip in-r>> first look-at-value ; - -M: #shuffle propagate* mapping>> at look-at-value ; - -: look-at-corresponding ( value inputs outputs -- ) - [ index ] dip over [ nth look-at-values ] [ 2drop ] if ; - -M: #phi propagate* - #! If any of the outputs of a #phi are live, then the - #! corresponding inputs are live too. - [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ] - [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ] - 2bi ; - -M: node propagate* 2drop ; - -: propogate-liveness ( value -- ) - live-values get 2dup key? [ - 2drop - ] [ - dupd conjoin - dup defined-by propagate* - ] if ; +: live-value? ( value -- ? ) live-values get at ; : compute-live-values ( node -- ) - #! We add f initially because #phi nodes can have f in their - #! inputs. - work-list set - H{ { f f } } clone live-values set - [ mark-live-values ] each-node - work-list get [ propogate-liveness ] slurp-dequeue ; + [ mark-live-values ] backward-dfa live-values set ; GENERIC: remove-dead-values* ( node -- ) +M: #introduce remove-dead-values* + [ [ live-value? ] filter ] change-values drop ; + M: #>r remove-dead-values* dup out-r>> first live-value? [ { } >>out-r ] unless dup in-d>> first live-value? [ { } >>in-d ] unless @@ -118,13 +56,6 @@ M: #push remove-dead-values* : filter-corresponding-values ( in out -- in' out' ) zip live-values get '[ drop _ , key? ] assoc-filter unzip ; -: remove-dead-copies ( node -- ) - dup - [ in-d>> ] [ out-d>> ] bi - filter-corresponding-values - [ >>in-d ] [ >>out-d ] bi* - drop ; - : filter-live ( values -- values' ) [ live-value? ] filter ; @@ -133,9 +64,16 @@ M: #shuffle remove-dead-values* [ filter-live ] change-out-d drop ; -M: #declare remove-dead-values* remove-dead-copies ; +M: #declare remove-dead-values* + [ [ drop live-value? ] assoc-filter ] change-declaration + drop ; -M: #copy remove-dead-values* remove-dead-copies ; +M: #copy remove-dead-values* + dup + [ in-d>> ] [ out-d>> ] bi + filter-corresponding-values + [ >>in-d ] [ >>out-d ] bi* + drop ; : remove-dead-phi-d ( #phi -- #phi ) dup @@ -156,46 +94,54 @@ M: #phi remove-dead-values* M: node remove-dead-values* drop ; +M: f remove-dead-values* drop ; + GENERIC: remove-dead-nodes* ( node -- newnode/t ) +: prune-if-empty ( node seq -- successor/t ) + empty? [ successor>> ] [ drop t ] if ; inline + +M: #introduce remove-dead-nodes* dup values>> prune-if-empty ; + : live-call? ( #call -- ? ) out-d>> [ live-value? ] contains? ; +M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ; + M: #call remove-dead-nodes* dup live-call? [ drop t ] [ [ in-d>> #drop ] [ successor>> ] bi >>successor ] if ; -: prune-if ( node quot -- successor/t ) - over >r call [ r> successor>> ] [ r> drop t ] if ; - inline +M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ; -M: #shuffle remove-dead-nodes* - [ in-d>> empty? ] prune-if ; +M: #push remove-dead-nodes* dup out-d>> prune-if-empty ; -M: #push remove-dead-nodes* - [ out-d>> empty? ] prune-if ; +M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ; -M: #>r remove-dead-nodes* - [ in-d>> empty? ] prune-if ; +M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ; -M: #r> remove-dead-nodes* - [ in-r>> empty? ] prune-if ; +M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ; + +: (remove-dead-code) ( node -- newnode ) + [ + dup remove-dead-values* + dup remove-dead-nodes* dup t eq? + [ drop ] [ nip (remove-dead-code) ] if + ] transform-nodes ; + +M: #if remove-dead-nodes* + [ (remove-dead-code) ] map-children t ; + +M: #dispatch remove-dead-nodes* + [ (remove-dead-code) ] map-children t ; + +M: #recursive remove-dead-nodes* + [ (remove-dead-code) ] change-child drop t ; M: node remove-dead-nodes* drop t ; -: (remove-dead-code) ( node -- newnode ) - dup [ - dup remove-dead-values* - dup remove-dead-nodes* dup t eq? [ - drop dup [ (remove-dead-code) ] map-children - ] [ - nip (remove-dead-code) - ] if - ] when ; +M: f remove-dead-nodes* drop t ; : remove-dead-code ( node -- newnode ) - [ - [ compute-live-values ] - [ [ (remove-dead-code) ] transform-nodes ] bi - ] with-scope ; + [ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ; diff --git a/unfinished/compiler/tree/def-use/def-use-tests.factor b/unfinished/compiler/tree/def-use/def-use-tests.factor index 967f253c06..34e28761ac 100755 --- a/unfinished/compiler/tree/def-use/def-use-tests.factor +++ b/unfinished/compiler/tree/def-use/def-use-tests.factor @@ -1,13 +1,13 @@ USING: accessors namespaces assocs kernel sequences math tools.test words sets combinators.short-circuit -stack-checker.state compiler.tree compiler.frontend +stack-checker.state compiler.tree compiler.tree.builder compiler.tree.def-use arrays kernel.private ; IN: compiler.tree.def-use.tests \ compute-def-use must-infer [ t ] [ - [ 1 2 3 ] dataflow compute-def-use drop + [ 1 2 3 ] build-tree compute-def-use drop def-use get { [ assoc-size 3 = ] [ values [ uses>> [ #return? ] all? ] all? ] @@ -29,5 +29,5 @@ IN: compiler.tree.def-use.tests [ [ 1 ] [ call 2 ] curry call + ] [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ] } [ - [ ] swap [ dataflow compute-def-use drop ] curry unit-test + [ ] swap [ build-tree compute-def-use drop ] curry unit-test ] each diff --git a/unfinished/compiler/tree/def-use/def-use.factor b/unfinished/compiler/tree/def-use/def-use.factor index cc5b1aaf57..c912582a38 100755 --- a/unfinished/compiler/tree/def-use/def-use.factor +++ b/unfinished/compiler/tree/def-use/def-use.factor @@ -28,6 +28,8 @@ TUPLE: definition value node uses ; GENERIC: node-uses-values ( node -- values ) +M: #declare node-uses-values declaration>> keys ; + M: #phi node-uses-values [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi append sift prune ; diff --git a/unfinished/compiler/tree/dfa/backward/backward.factor b/unfinished/compiler/tree/dfa/backward/backward.factor new file mode 100644 index 0000000000..cb2b13e6bb --- /dev/null +++ b/unfinished/compiler/tree/dfa/backward/backward.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.tree.dfa.backward +USING: accessors sequences assocs kernel compiler.tree +compiler.tree.dfa ; + +GENERIC: backward ( value node -- ) + +M: #copy backward + #! If the output of a copy is live, then the corresponding + #! input is live also. + [ out-d>> index ] keep in-d>> nth look-at-value ; + +M: #call backward + #! If any of the outputs of a call are live, then all + #! inputs and outputs must be live. + nip [ look-at-inputs ] [ look-at-outputs ] bi ; + +M: #call-recursive backward + #! If the output of a copy is live, then the corresponding + #! inputs to #return nodes are live also. + [ out-d>> index ] keep label>> returns>> + [ nth look-at-value ] with each ; + +M: #>r backward nip in-d>> first look-at-value ; + +M: #r> backward nip in-r>> first look-at-value ; + +M: #shuffle backward mapping>> at look-at-value ; + +M: #phi backward + #! If any of the outputs of a #phi are live, then the + #! corresponding inputs are live too. + [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ] + [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ] + 2bi ; + +M: node backward 2drop ; + +: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline diff --git a/unfinished/compiler/tree/dfa/dfa.factor b/unfinished/compiler/tree/dfa/dfa.factor new file mode 100644 index 0000000000..3a7770c53f --- /dev/null +++ b/unfinished/compiler/tree/dfa/dfa.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: fry accessors namespaces assocs dequeues search-dequeues +kernel sequences words sets stack-checker.inlining compiler.tree +compiler.tree.def-use compiler.tree.combinators ; +IN: compiler.tree.dfa + +! Dataflow analysis +SYMBOL: work-list + +: look-at-value ( values -- ) + work-list get push-front ; + +: look-at-values ( values -- ) + work-list get '[ , push-front ] each ; + +: look-at-inputs ( node -- ) in-d>> look-at-values ; + +: look-at-outputs ( node -- ) out-d>> look-at-values ; + +: look-at-corresponding ( value inputs outputs -- ) + [ index ] dip over [ nth look-at-values ] [ 2drop ] if ; + +: init-dfa ( -- ) + #! We add f initially because #phi nodes can have f in their + #! inputs. + work-list set ; + +: iterate-dfa ( value assoc quot -- ) + 2over key? [ + 3drop + ] [ + [ dupd conjoin dup defined-by ] dip call + ] if ; inline + +: dfa ( node mark-quot iterate-quot -- assoc ) + init-dfa + [ each-node ] dip + work-list get H{ { f f } } clone + [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index b95b7f0750..63cb05de0a 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 +math.intervals arrays classes.algebra locals compiler.tree compiler.tree.def-use compiler.tree.propagation.info @@ -14,19 +14,28 @@ IN: compiler.tree.propagation.branches GENERIC: child-constraints ( node -- seq ) M: #if child-constraints - in-d>> first - [ ] [ ] bi - 2array ; + in-d>> first [ =t ] [ =f ] bi 2array ; M: #dispatch child-constraints drop f ; +GENERIC: live-children ( #branch -- children ) + +M: #if live-children + [ children>> ] [ in-d>> first value-info possible-boolean-values ] bi + [ t swap memq? [ first ] [ drop f ] if ] + [ f swap memq? [ second ] [ drop f ] if ] + 2bi 2array ; + +M: #dispatch live-children + children>> ; + : infer-children ( node -- assocs ) - [ children>> ] [ child-constraints ] bi [ + [ live-children ] [ child-constraints ] bi [ [ value-infos [ clone ] change constraints [ clone ] change assume - (propagate) + [ first>> (propagate) ] when* ] H{ } make-assoc ] 2map ; @@ -37,13 +46,23 @@ M: #dispatch child-constraints drop f ; [ swap (merge-value-infos) ] dip set-value-infos ; : propagate-branch-phi ( results #phi -- ) - [ nip node-defs-values [ introduce-value ] each ] [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ] [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ] - 2tri ; + 2bi ; + +:: branch-phi-constraints ( x #phi -- ) + #phi [ out-d>> ] [ phi-in-d>> ] bi [ + first2 2dup and [ USE: prettyprint + [ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup . assume ] + [ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup . assume ] + 3bi + ] [ 3drop ] if + ] 2each ; : merge-children ( results node -- ) - successor>> propagate-branch-phi ; + [ 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 ; diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor index 0a0e779427..e49e478ec4 100644 --- a/unfinished/compiler/tree/propagation/constraints/constraints.factor +++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor @@ -2,7 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs math math.intervals kernel accessors sequences namespaces disjoint-sets classes classes.algebra -combinators words compiler.tree compiler.tree.propagation.info ; +combinators words +compiler.tree compiler.tree.propagation.info +compiler.tree.copy-equiv ; IN: compiler.tree.propagation.constraints ! A constraint is a statement about a value. @@ -12,12 +14,12 @@ SYMBOL: constraints GENERIC: assume ( constraint -- ) GENERIC: satisfied? ( constraint -- ? ) +GENERIC: satisfiable? ( constraint -- ? ) ! Boolean constraints TUPLE: true-constraint value ; -: ( value -- constriant ) - resolve-copy true-constraint boa ; +: =t ( value -- constriant ) resolve-copy true-constraint boa ; M: true-constraint assume [ constraints get at [ assume ] when* ] @@ -27,10 +29,12 @@ M: true-constraint assume M: true-constraint satisfied? value>> value-info class>> \ f class-not class<= ; +M: true-constraint satisfiable? + value>> value-info class>> \ f class-not classes-intersect? ; + TUPLE: false-constraint value ; -: ( value -- constriant ) - resolve-copy false-constraint boa ; +: =f ( value -- constriant ) resolve-copy false-constraint boa ; M: false-constraint assume [ constraints get at [ assume ] when* ] @@ -40,10 +44,13 @@ M: false-constraint assume M: false-constraint satisfied? value>> value-info class>> \ f class<= ; +M: false-constraint satisfiable? + value>> value-info class>> \ f classes-intersect? ; + ! Class constraints TUPLE: class-constraint value class ; -: ( value class -- constraint ) +: is-instance-of ( value class -- constraint ) [ resolve-copy ] dip class-constraint boa ; M: class-constraint assume @@ -52,7 +59,7 @@ M: class-constraint assume ! Interval constraints TUPLE: interval-constraint value interval ; -: ( value interval -- constraint ) +: is-in-interval ( value interval -- constraint ) [ resolve-copy ] dip interval-constraint boa ; M: interval-constraint assume @@ -61,7 +68,7 @@ M: interval-constraint assume ! Literal constraints TUPLE: literal-constraint value literal ; -: ( value literal -- constraint ) +: is-equal-to ( value literal -- constraint ) [ resolve-copy ] dip literal-constraint boa ; M: literal-constraint assume @@ -70,29 +77,48 @@ M: literal-constraint assume ! Implication constraints TUPLE: implication p q ; -C: implication +C: --> implication M: implication assume [ q>> ] [ p>> ] bi [ constraints get set-at ] [ satisfied? [ assume ] [ drop ] if ] 2bi ; +M: implication satisfiable? + [ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ; + ! Conjunction constraints TUPLE: conjunction p q ; -C: conjunction +C: /\ conjunction M: conjunction assume [ p>> assume ] [ q>> assume ] bi ; +M: conjunction satisfiable? + [ p>> satisfiable? ] [ q>> satisfiable? ] bi and ; + +! Disjunction constraints +TUPLE: disjunction p q ; + +C: \/ disjunction + +M: disjunction assume + { + { [ dup p>> satisfiable? not ] [ q>> assume ] } + { [ dup q>> satisfiable? not ] [ p>> assume ] } + [ drop ] + } cond ; + +M: disjunction satisfiable? + [ p>> satisfiable? ] [ q>> satisfiable? ] bi or ; + ! No-op M: f assume drop ; ! Utilities -: if-true ( constraint boolean-value -- constraint' ) - swap ; +: t--> ( constraint boolean-value -- constraint' ) =t swap --> ; -: if-false ( constraint boolean-value -- constraint' ) - swap ; +: f--> ( constraint boolean-value -- constraint' ) =f swap --> ; : ( true-constr false-constr boolean-value -- constraint ) - tuck [ if-true ] [ if-false ] 2bi* ; + tuck [ t--> ] [ f--> ] 2bi* /\ ; diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor index 5ae54d3b2a..8503b8d98d 100644 --- a/unfinished/compiler/tree/propagation/info/info-tests.factor +++ b/unfinished/compiler/tree/propagation/info/info-tests.factor @@ -2,6 +2,8 @@ USING: accessors math math.intervals sequences classes.algebra math kernel tools.test compiler.tree.propagation.info ; IN: compiler.tree.propagation.info.tests +[ f ] [ 0.0 -0.0 eql? ] unit-test + [ t ] [ number sequence @@ -49,7 +51,7 @@ IN: compiler.tree.propagation.info.tests value-info-intersect >literal< ] unit-test -[ T{ value-info f fixnum empty-interval f f } ] [ +[ T{ value-info f null empty-interval f f } ] [ fixnum -10 0 [a,b] fixnum 19 29 [a,b] value-info-intersect diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 76862846cd..dea5808fa6 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -1,26 +1,19 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes classes.algebra kernel accessors math -math.intervals namespaces disjoint-sets sequences words -combinators ; +math.intervals namespaces sequences words combinators arrays +compiler.tree.copy-equiv ; IN: compiler.tree.propagation.info SYMBOL: +interval+ GENERIC: eql? ( obj1 obj2 -- ? ) M: object eql? eq? ; -M: number eql? [ [ class ] bi@ = ] [ number= ] 2bi and ; - -! Disjoint set of copy equivalence -SYMBOL: copies - -: is-copy-of ( val copy -- ) copies get equate ; - -: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ; - -: resolve-copy ( copy -- val ) copies get representative ; - -: introduce-value ( val -- ) copies get add-atom ; +M: fixnum eql? eq? ; +M: bignum eql? over bignum? [ = ] [ 2drop f ] if ; +M: ratio eql? over ratio? [ = ] [ 2drop f ] if ; +M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ; +M: complex eql? over complex? [ = ] [ 2drop f ] if ; ! Value info represents a set of objects. Don't mutate value infos ! you receive, always construct new ones. We don't declare the @@ -36,16 +29,18 @@ literal? ; [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ; : interval>literal ( class interval -- literal literal? ) + #! If interval has zero length and the class is sufficiently + #! precise, we can turn it into a literal dup empty-interval eq? [ 2drop f f ] [ dup from>> first { { [ over interval-length 0 > ] [ 3drop f f ] } - { [ over from>> second not ] [ 3drop f f ] } - { [ over to>> second not ] [ 3drop f f ] } - { [ pick fixnum class<= ] [ 2nip >fixnum t ] } { [ pick bignum class<= ] [ 2nip >bignum t ] } - { [ pick float class<= ] [ 2nip >float t ] } + { [ pick integer class<= ] [ 2nip >fixnum t ] } + { [ pick float class<= ] [ + 2nip dup zero? [ drop f f ] [ >float t ] if + ] } [ 3drop f f ] } cond ] if ; @@ -53,13 +48,13 @@ literal? ; : ( class interval literal literal? -- info ) [ 2nip - [ class ] - [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] - [ ] - tri t + [ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri + t ] [ drop - over null class<= [ drop empty-interval f f ] [ + 2dup [ null class<= ] [ empty-interval eq? ] bi* or [ + 2drop null empty-interval f f + ] [ over integer class<= [ integral-closure ] when 2dup interval>literal ] if @@ -70,13 +65,14 @@ literal? ; f f ; foldable : ( class -- info ) - [-inf,inf] ; foldable + dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or + ; foldable : ( interval -- info ) real swap ; foldable : ( literal -- info ) - f [-inf,inf] rot t ; foldable + f f rot t ; foldable : >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ; @@ -122,3 +118,15 @@ SYMBOL: value-infos : value-literal ( value -- obj ? ) value-info >literal< ; + +: possible-boolean-values ( info -- values ) + dup literal?>> [ + literal>> 1array + ] [ + class>> { + { [ dup null class<= ] [ { } ] } + { [ dup \ f class-not class<= ] [ { t } ] } + { [ dup \ f class<= ] [ { f } ] } + [ { t f } ] + } cond nip + ] if ; diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor index 524584258a..e358dd5be1 100644 --- a/unfinished/compiler/tree/propagation/known-words/known-words.factor +++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor @@ -1,23 +1,15 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel effects accessors math math.private math.libm -math.partial-dispatch math.intervals math.parser layouts words -sequences sequences.private arrays assocs classes +math.partial-dispatch math.intervals math.parser math.order +layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private compiler.tree.propagation.info compiler.tree.propagation.nodes -compiler.tree.propagation.constraints ; +compiler.tree.propagation.constraints +compiler.tree.comparisons ; IN: compiler.tree.propagation.known-words -\ and [ - [ [ ] bi@ ] dip if-true -] +constraints+ set-word-prop - -\ not [ - [ [ ] [ ] bi ] dip - -] +constraints+ set-word-prop - \ fixnum most-negative-fixnum most-positive-fixnum [a,b] +interval+ set-word-prop @@ -88,7 +80,7 @@ most-negative-fixnum most-positive-fixnum [a,b] ] if ; : binary-op-interval ( info1 info2 quot -- newinterval ) - [ [ interval>> ] bi@ 2dup and ] dip [ 2drop f ] if ; inline + [ [ interval>> ] bi@ ] dip call ; inline : won't-overflow? ( class interval -- ? ) [ fixnum class<= ] [ fixnum fits? ] bi* and ; @@ -148,36 +140,12 @@ most-negative-fixnum most-positive-fixnum [a,b] \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op -: assume-interval ( i1 i2 op -- i3 ) - { - { \ < [ assume< ] } - { \ > [ assume> ] } - { \ <= [ assume<= ] } - { \ >= [ assume>= ] } - } case ; - -: swap-comparison ( op -- op' ) - { - { < > } - { > < } - { <= >= } - { >= <= } - } at ; - -: negate-comparison ( op -- op' ) - { - { < >= } - { > <= } - { <= > } - { >= < } - } at ; - :: (comparison-constraints) ( in1 in2 op -- constraint ) [let | i1 [ in1 value-info interval>> ] i2 [ in2 value-info interval>> ] | - in1 i1 i2 op assume-interval - in2 i2 i1 op swap-comparison assume-interval - + in1 i1 i2 op assumption is-in-interval + in2 i2 i1 op swap-comparison assumption is-in-interval + /\ ] ; : comparison-constraints ( in1 in2 out op -- constraint ) @@ -187,10 +155,35 @@ most-negative-fixnum most-positive-fixnum [a,b] 3bi ] dip ; -: comparison-op ( word op -- ) +: define-comparison-constraints ( word op -- ) '[ , comparison-constraints ] +constraints+ set-word-prop ; -{ < > <= >= } [ dup [ comparison-op ] curry each-derived-op ] each +comparison-ops +[ dup '[ , define-comparison-constraints ] each-derived-op ] each + +generic-comparison-ops [ + dup specific-comparison + '[ , , define-comparison-constraints ] each-derived-op +] each + +! Remove redundant comparisons +: fold-comparison ( info1 info2 word -- info ) + [ [ interval>> ] bi@ ] dip interval-comparison { + { incomparable [ object ] } + { t [ t ] } + { f [ f ] } + } case ; + +comparison-ops [ + [ + dup '[ , fold-comparison ] +outputs+ set-word-prop + ] each-derived-op +] each + +generic-comparison-ops [ + dup specific-comparison + '[ , fold-comparison ] +outputs+ set-word-prop +] each { { >fixnum fixnum } diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor index a996e32959..8da5b91f64 100644 --- a/unfinished/compiler/tree/propagation/nodes/nodes.factor +++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor @@ -16,9 +16,6 @@ GENERIC: propagate-around ( node -- ) : (propagate) ( node -- ) [ - [ node-defs-values [ introduce-value ] each ] - [ propagate-around ] - [ successor>> ] - tri + [ 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 72a9566281..64ab3df807 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -1,5 +1,6 @@ -USING: kernel compiler.frontend compiler.tree -compiler.tree.propagation tools.test math math.order +USING: kernel compiler.tree.builder compiler.tree +compiler.tree.propagation compiler.tree.copy-equiv +compiler.tree.def-use tools.test math math.order accessors sequences arrays kernel.private vectors alien.accessors alien.c-types ; IN: compiler.tree.propagation.tests @@ -8,7 +9,11 @@ IN: compiler.tree.propagation.tests \ propagate/node must-infer : final-info ( quot -- seq ) - dataflow propagate last-node node-input-infos ; + build-tree + compute-def-use + compute-copy-equiv + propagate + last-node node-input-infos ; : final-classes ( quot -- seq ) final-info [ class>> ] map ; @@ -116,7 +121,7 @@ IN: compiler.tree.propagation.tests [ V{ 9 } ] [ [ - >fixnum + 123 bitand dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if ] final-literals ] unit-test @@ -143,3 +148,52 @@ IN: compiler.tree.propagation.tests 255 min 0 max ] final-classes ] unit-test + +[ V{ fixnum } ] [ + [ 0 dup 10 > [ 2 * ] when ] final-classes +] unit-test + +[ V{ f } ] [ + [ [ 0.0 ] [ -0.0 ] if ] final-literals +] unit-test + +[ V{ 1.5 } ] [ + [ /f 1.5 min 1.5 max ] final-literals +] unit-test + +[ V{ 1.5 } ] [ + [ + /f + dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if + ] final-literals +] unit-test + +[ V{ 1.5 } ] [ + [ + /f + dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if + ] final-literals +] unit-test + +[ V{ f } ] [ + [ + /f + dup 0.0 < [ dup 0.0 > [ drop 0.0 ] unless ] [ drop 0.0 ] if + ] final-literals +] unit-test + +[ V{ fixnum } ] [ + [ 0 dup 10 > [ 100 * ] when ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ 0 dup 10 > [ drop "foo" ] when ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ { fixnum } declare 3 3 - + ] final-classes +] unit-test + +[ V{ t } ] [ + [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals +] unit-test diff --git a/unfinished/compiler/tree/propagation/propagation.factor b/unfinished/compiler/tree/propagation/propagation.factor index ff822f6f92..4a8686a1e4 100755 --- a/unfinished/compiler/tree/propagation/propagation.factor +++ b/unfinished/compiler/tree/propagation/propagation.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences namespaces hashtables -disjoint-sets compiler.tree compiler.tree.def-use compiler.tree.propagation.info @@ -17,7 +16,6 @@ IN: compiler.tree.propagation [ H{ } clone constraints set >hashtable value-infos set - copies set (propagate) ] with-scope ; diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 2223e1dd13..731b0d06f7 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -8,6 +8,12 @@ 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 + : (merge-value-infos) ( inputs -- infos ) [ [ value-info ] map value-infos-union ] map ; @@ -22,11 +28,9 @@ IN: compiler.tree.propagation.recursive M: #recursive propagate-around ( #recursive -- ) dup - [ children>> (propagate) ] - [ node-child propagate-recursive-phi ] bi + node-child + [ first>> (propagate) ] [ propagate-recursive-phi ] bi [ drop ] [ propagate-around ] if ; M: #call-recursive propagate-before ( #call-label -- ) - #! What if we reach a fixed point for the phi but not for the - #! #call-label output? [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ; diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index f7dea223b5..b02f7700a6 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/unfinished/compiler/tree/propagation/simple/simple.factor @@ -3,6 +3,7 @@ USING: fry accessors kernel sequences assocs words namespaces classes.algebra combinators classes continuations compiler.tree +compiler.tree.def-use compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.constraints ; @@ -25,29 +26,12 @@ M: #push propagate-before [ set-value-info ] 2each ; M: #declare propagate-before - [ [ in-d>> ] [ out-d>> ] bi are-copies-of ] - [ - [ declaration>> class-infos ] [ out-d>> ] bi - refine-value-infos - ] bi ; - -M: #shuffle propagate-before - [ out-d>> dup ] [ mapping>> ] bi - '[ , at ] map swap are-copies-of ; - -M: #>r propagate-before - [ in-d>> ] [ out-r>> ] bi are-copies-of ; - -M: #r> propagate-before - [ in-r>> ] [ out-d>> ] bi are-copies-of ; - -M: #copy propagate-before - [ in-d>> ] [ out-d>> ] bi are-copies-of ; + declaration>> [ swap refine-value-info ] assoc-each ; : predicate-constraints ( value class boolean-value -- constraint ) - [ [ ] dip if-true ] - [ [ class-not ] dip if-false ] - 3bi ; + [ [ is-instance-of ] dip t--> ] + [ [ class-not is-instance-of ] dip f--> ] + 3bi /\ ; : custom-constraints ( #call quot -- ) [ [ in-d>> ] [ out-d>> ] bi append ] dip @@ -63,6 +47,24 @@ M: #copy propagate-before ] [ drop ] if ] if* ; +: call-outputs-quot ( node -- infos ) + [ in-d>> [ value-info ] map ] + [ word>> +outputs+ word-prop ] + bi with-datastack ; + +: foldable-call? ( #call -- ? ) + dup word>> "foldable" word-prop [ + in-d>> [ value-info literal?>> ] all? + ] [ + drop f + ] if ; + +: fold-call ( #call -- infos ) + [ in-d>> [ value-info literal>> ] map ] + [ word>> [ execute ] curry ] + bi with-datastack + [ ] map ; + : default-output-value-infos ( node -- infos ) dup word>> "default-output-classes" word-prop [ class-infos @@ -70,12 +72,12 @@ M: #copy propagate-before out-d>> length object ] ?if ; -: call-outputs-quot ( node quot -- infos ) - [ in-d>> [ value-info ] map ] dip with-datastack ; - : output-value-infos ( node -- infos ) - dup word>> +outputs+ word-prop - [ call-outputs-quot ] [ default-output-value-infos ] if* ; + { + { [ dup foldable-call? ] [ fold-call ] } + { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] } + [ default-output-value-infos ] + } cond ; M: #call propagate-before [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ] @@ -94,7 +96,10 @@ M: #call propagate-after M: node propagate-after drop ; : annotate-node ( node -- ) - dup node-values [ dup value-info ] H{ } map>assoc >>info drop ; + dup + [ node-defs-values ] [ node-uses-values ] bi append + [ dup value-info ] H{ } map>assoc + >>info drop ; M: node propagate-around [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ; diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor index e528a48db9..5d15fc9185 100755 --- a/unfinished/compiler/tree/tree.factor +++ b/unfinished/compiler/tree/tree.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs kernel math namespaces parser sequences words vectors math.intervals effects classes -accessors combinators stack-checker.state ; +accessors combinators stack-checker.state stack-checker.visitor ; IN: compiler.tree ! High-level tree SSA form. @@ -16,20 +16,12 @@ IN: compiler.tree ! case of a #phi node, the sequence of sequences in the phi-in-r ! and phi-in-d slots. ! 3) A value is never used in the same node where it is defined. - TUPLE: node < identity-tuple in-d out-d in-r out-r info -history successor children ; +successor children ; M: node hashcode* drop node hashcode* ; -: node-shuffle ( node -- shuffle ) - [ in-d>> ] [ out-d>> ] bi ; - -: node-values ( node -- values ) - { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave - 4array concat ; - : node-child ( node -- child ) children>> first ; : last-node ( node -- last ) @@ -57,7 +49,7 @@ TUPLE: #introduce < node values ; : #introduce ( values -- node ) \ #introduce new swap >>values ; -TUPLE: #call < node word ; +TUPLE: #call < node word history ; : #call ( inputs outputs word -- node ) \ #call new @@ -137,11 +129,9 @@ TUPLE: #phi < node phi-in-d phi-in-r ; TUPLE: #declare < node declaration ; -: #declare ( inputs outputs declaration -- node ) +: #declare ( declaration -- node ) \ #declare new - swap >>declaration - swap >>out-d - swap >>in-d ; + swap >>declaration ; TUPLE: #return < node label ; @@ -172,3 +162,30 @@ DEFER: #tail? PREDICATE: #tail-phi < #phi successor>> #tail? ; UNION: #tail POSTPONE: f #return #tail-phi #terminate ; + +TUPLE: node-list first last ; + +: node, ( node -- ) + stack-visitor get swap + over last>> + [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ] + [ [ >>first ] [ >>last ] bi drop ] + if ; + +M: node-list child-visitor node-list new ; +M: node-list #introduce, #introduce node, ; +M: node-list #call, #call node, ; +M: node-list #call-recursive, #call-recursive node, ; +M: node-list #push, #push node, ; +M: node-list #shuffle, #shuffle node, ; +M: node-list #drop, #drop node, ; +M: node-list #>r, #>r node, ; +M: node-list #r>, #r> node, ; +M: node-list #return, #return node, ; +M: node-list #terminate, #terminate node, ; +M: node-list #if, #if node, ; +M: node-list #dispatch, #dispatch node, ; +M: node-list #phi, #phi node, ; +M: node-list #declare, #declare node, ; +M: node-list #recursive, #recursive node, ; +M: node-list #copy, #copy node, ; diff --git a/unfinished/compiler/tree/untupling/untupling-tests.factor b/unfinished/compiler/tree/untupling/untupling-tests.factor new file mode 100644 index 0000000000..27d8a66153 --- /dev/null +++ b/unfinished/compiler/tree/untupling/untupling-tests.factor @@ -0,0 +1,50 @@ +IN: compiler.tree.untupling.tests +USING: assocs math kernel quotations.private slots.private +compiler.tree.builder +compiler.tree.def-use +compiler.tree.copy-equiv +compiler.tree.untupling +tools.test ; + +: check-untupling ( quot -- sizes ) + build-tree + compute-copy-equiv + compute-def-use + compute-untupling + values ; + +[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test + +[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test + +[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test + +[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test + +[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test + +[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test + +[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test + +[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test + +[ { 2 2 } ] [ + [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling +] unit-test + +[ { } ] [ + [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling +] unit-test + +[ { 2 2 2 } ] [ + [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling +] unit-test + +[ { 2 2 } ] [ + [ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling +] unit-test + +[ { } ] [ + [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling +] unit-test diff --git a/unfinished/compiler/tree/untupling/untupling.factor b/unfinished/compiler/tree/untupling/untupling.factor new file mode 100644 index 0000000000..6fb51e3fa1 --- /dev/null +++ b/unfinished/compiler/tree/untupling/untupling.factor @@ -0,0 +1,59 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors slots.private kernel namespaces disjoint-sets +math sequences assocs classes.tuple.private combinators fry sets +compiler.tree compiler.tree.combinators compiler.tree.copy-equiv +compiler.tree.dfa compiler.tree.dfa.backward ; +IN: compiler.tree.untupling + +SYMBOL: escaping-values + +: mark-escaping-values ( node -- ) + in-d>> escaping-values get '[ resolve-copy , conjoin ] each ; + +SYMBOL: untupling-candidates + +: untupling-candidate ( #call class -- ) + #! 1- for delegate + size>> 1- swap out-d>> first resolve-copy + untupling-candidates get set-at ; + +GENERIC: compute-untupling* ( node -- ) + +M: #call compute-untupling* + dup word>> { + { \ [ dup in-d>> peek untupling-candidate ] } + { \ curry [ \ curry tuple-layout untupling-candidate ] } + { \ compose [ \ compose tuple-layout untupling-candidate ] } + { \ slot [ drop ] } + [ drop mark-escaping-values ] + } case ; + +M: #return compute-untupling* + dup label>> [ drop ] [ mark-escaping-values ] if ; + +M: node compute-untupling* drop ; + +GENERIC: check-consistency* ( node -- ) + +: check-value-consistency ( out-value in-values -- ) + swap escaping-values get key? [ + escaping-values get '[ , conjoin ] each + ] [ + untupling-candidates get 2dup '[ , at ] map all-equal? + [ 2drop ] [ '[ , delete-at ] each ] if + ] if ; + +M: #phi check-consistency* + [ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ] + [ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ] + bi ; + +M: node check-consistency* drop ; + +: compute-untupling ( node -- assoc ) + H{ } clone escaping-values set + H{ } clone untupling-candidates set + [ [ compute-untupling* ] each-node ] + [ [ check-consistency* ] each-node ] bi + untupling-candidates get escaping-values get assoc-diff ; diff --git a/unfinished/stack-checker/backend/backend.factor b/unfinished/stack-checker/backend/backend.factor index 8fb897d8c6..900980c0ea 100755 --- a/unfinished/stack-checker/backend/backend.factor +++ b/unfinished/stack-checker/backend/backend.factor @@ -176,7 +176,7 @@ M: object apply-object push-literal ; [ init-inference init-known-values - dataflow-visitor off + stack-visitor off dependencies off [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ] [ finish-word current-effect ] @@ -202,10 +202,10 @@ M: object apply-object push-literal ; V{ } clone recorded set init-inference init-known-values - dataflow-visitor off + stack-visitor off call end-infer current-effect - dataflow-visitor get + stack-visitor get ] [ ] [ undo-infer ] cleanup ] with-scope ; inline diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor index dd7e37c2df..613cf31161 100644 --- a/unfinished/stack-checker/branches/branches.factor +++ b/unfinished/stack-checker/branches/branches.factor @@ -65,7 +65,7 @@ SYMBOL: quotations : infer-branches ( branches -- input children data ) [ pop-d ] dip [ infer-branch ] map - [ dataflow-visitor branch-variable ] keep ; + [ stack-visitor branch-variable ] keep ; : (infer-if) ( branches -- ) infer-branches [ first2 #if, ] dip compute-phi-function ; diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor index 231d7078b9..7c24ddf9ea 100644 --- a/unfinished/stack-checker/inlining/inlining.factor +++ b/unfinished/stack-checker/inlining/inlining.factor @@ -81,7 +81,7 @@ SYMBOL: phi-out dup recursive-word-inputs meta-d get - dataflow-visitor get + stack-visitor get ] with-scope ; : inline-recursive-word ( word -- ) diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor index 6c36dd25a9..01991147f7 100755 --- a/unfinished/stack-checker/known-words/known-words.factor +++ b/unfinished/stack-checker/known-words/known-words.factor @@ -52,7 +52,7 @@ IN: stack-checker.known-words : infer-declare ( -- ) pop-literal nip - [ length consume-d dup copy-values dup output-d ] keep + [ length ensure-d ] keep zip #declare, ; GENERIC: infer-call* ( value known -- ) diff --git a/unfinished/stack-checker/visitor/dummy/dummy.factor b/unfinished/stack-checker/visitor/dummy/dummy.factor index 0bbf25193c..dc20d6acb1 100644 --- a/unfinished/stack-checker/visitor/dummy/dummy.factor +++ b/unfinished/stack-checker/visitor/dummy/dummy.factor @@ -16,7 +16,7 @@ M: f #terminate, ; M: f #if, 3drop ; M: f #dispatch, 2drop ; M: f #phi, 2drop 2drop ; -M: f #declare, 3drop ; +M: f #declare, drop ; M: f #recursive, drop drop drop drop drop ; M: f #copy, 2drop ; M: f #drop, drop ; diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor index 18c914ba1c..de9fa947c7 100644 --- a/unfinished/stack-checker/visitor/visitor.factor +++ b/unfinished/stack-checker/visitor/visitor.factor @@ -3,25 +3,25 @@ USING: kernel arrays namespaces ; IN: stack-checker.visitor -SYMBOL: dataflow-visitor +SYMBOL: stack-visitor -HOOK: child-visitor dataflow-visitor ( -- visitor ) +HOOK: child-visitor stack-visitor ( -- visitor ) -: nest-visitor ( -- ) child-visitor dataflow-visitor set ; +: nest-visitor ( -- ) child-visitor stack-visitor set ; -HOOK: #introduce, dataflow-visitor ( values -- ) -HOOK: #call, dataflow-visitor ( inputs outputs word -- ) -HOOK: #call-recursive, dataflow-visitor ( inputs outputs word -- ) -HOOK: #push, dataflow-visitor ( literal value -- ) -HOOK: #shuffle, dataflow-visitor ( inputs outputs mapping -- ) -HOOK: #drop, dataflow-visitor ( values -- ) -HOOK: #>r, dataflow-visitor ( inputs outputs -- ) -HOOK: #r>, dataflow-visitor ( inputs outputs -- ) -HOOK: #terminate, dataflow-visitor ( -- ) -HOOK: #if, dataflow-visitor ( ? true false -- ) -HOOK: #dispatch, dataflow-visitor ( n branches -- ) -HOOK: #phi, dataflow-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- ) -HOOK: #declare, dataflow-visitor ( inputs outputs declaration -- ) -HOOK: #return, dataflow-visitor ( label stack -- ) -HOOK: #recursive, dataflow-visitor ( word label inputs outputs visitor -- ) -HOOK: #copy, dataflow-visitor ( inputs outputs -- ) +HOOK: #introduce, stack-visitor ( values -- ) +HOOK: #call, stack-visitor ( inputs outputs word -- ) +HOOK: #call-recursive, stack-visitor ( inputs outputs word -- ) +HOOK: #push, stack-visitor ( literal value -- ) +HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- ) +HOOK: #drop, stack-visitor ( values -- ) +HOOK: #>r, stack-visitor ( inputs outputs -- ) +HOOK: #r>, stack-visitor ( inputs outputs -- ) +HOOK: #terminate, stack-visitor ( -- ) +HOOK: #if, stack-visitor ( ? true false -- ) +HOOK: #dispatch, stack-visitor ( n branches -- ) +HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- ) +HOOK: #declare, stack-visitor ( declaration -- ) +HOOK: #return, stack-visitor ( label stack -- ) +HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- ) +HOOK: #copy, stack-visitor ( inputs outputs -- )