diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor new file mode 100644 index 0000000000..975adfa6cb --- /dev/null +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -0,0 +1,140 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs deques dlists kernel locals sequences lexer +namespaces functors compiler.cfg.rpo compiler.cfg.utilities +compiler.cfg ; +IN: compiler.cfg.dataflow-analysis + +GENERIC: join-sets ( sets dfa -- set ) +GENERIC: transfer-set ( in-set bb dfa -- out-set ) +GENERIC: block-order ( cfg dfa -- bbs ) +GENERIC: successors ( bb dfa -- seq ) +GENERIC: predecessors ( bb dfa -- seq ) + + ( cfg dfa -- queue ) + block-order [ push-all-front ] keep ; + +GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) + +M: kill-block compute-in-set 3drop f ; + +M:: basic-block compute-in-set ( bb out-sets dfa -- set ) + bb dfa predecessors [ out-sets at ] map dfa join-sets ; + +:: update-in-set ( bb in-sets out-sets dfa -- ? ) + bb out-sets dfa compute-in-set + bb in-sets maybe-set-at ; inline + +GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) + +M: kill-block compute-out-set 3drop f ; + +M:: basic-block compute-out-set ( bb in-sets dfa -- set ) + bb in-sets at bb dfa transfer-set ; + +:: update-out-set ( bb in-sets out-sets dfa -- ? ) + bb in-sets dfa compute-out-set + bb out-sets maybe-set-at ; inline + +:: dfa-step ( bb in-sets out-sets dfa work-list -- ) + bb in-sets out-sets dfa update-in-set [ + bb in-sets out-sets dfa update-out-set [ + bb dfa successors work-list push-all-front + ] when + ] when ; inline + +:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets ) + H{ } clone :> in-sets + H{ } clone :> out-sets + cfg dfa :> work-list + work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque + in-sets + out-sets ; inline + +M: dataflow-analysis join-sets drop assoc-refine ; + +FUNCTOR: define-analysis ( name -- ) + +name-analysis DEFINES-CLASS ${name}-analysis +name-ins DEFINES ${name}-ins +name-outs DEFINES ${name}-outs +name-in DEFINES ${name}-in +name-out DEFINES ${name}-out + +WHERE + +SINGLETON: name-analysis + +SYMBOL: name-ins + +: name-in ( bb -- set ) name-ins get at ; + +SYMBOL: name-outs + +: name-out ( bb -- set ) name-outs get at ; + +;FUNCTOR + +! ! ! Forward dataflow analysis + +MIXIN: forward-analysis +INSTANCE: forward-analysis dataflow-analysis + +M: forward-analysis block-order drop reverse-post-order ; +M: forward-analysis successors drop successors>> ; +M: forward-analysis predecessors drop predecessors>> ; + +FUNCTOR: define-forward-analysis ( name -- ) + +name-analysis IS ${name}-analysis +name-ins IS ${name}-ins +name-outs IS ${name}-outs +compute-name-sets DEFINES compute-${name}-sets + +WHERE + +INSTANCE: name-analysis forward-analysis + +: compute-name-sets ( cfg -- ) + name-analysis run-dataflow-analysis + [ name-ins set ] [ name-outs set ] bi* ; + +;FUNCTOR + +! ! ! Backward dataflow analysis + +MIXIN: backward-analysis +INSTANCE: backward-analysis dataflow-analysis + +M: backward-analysis block-order drop post-order ; +M: backward-analysis successors drop predecessors>> ; +M: backward-analysis predecessors drop successors>> ; + +FUNCTOR: define-backward-analysis ( name -- ) + +name-analysis IS ${name}-analysis +name-ins IS ${name}-ins +name-outs IS ${name}-outs +compute-name-sets DEFINES compute-${name}-sets + +WHERE + +INSTANCE: name-analysis backward-analysis + +: compute-name-sets ( cfg -- ) + \ name-analysis run-dataflow-analysis + [ name-outs set ] [ name-ins set ] bi* ; + +;FUNCTOR + +PRIVATE> + +SYNTAX: FORWARD-ANALYSIS: + scan [ define-analysis ] [ define-forward-analysis ] bi ; + +SYNTAX: BACKWARD-ANALYSIS: + scan [ define-analysis ] [ define-backward-analysis ] bi ; diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 6ffc4d8112..5129515980 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.mixin classes.parser -classes.tuple classes.tuple.parser combinators effects -effects.parser fry generic generic.parser generic.standard -interpolate io.streams.string kernel lexer locals.parser -locals.rewrite.closures locals.types make namespaces parser -quotations sequences vocabs.parser words words.symbol ; +USING: accessors arrays classes.mixin classes.parser classes.singleton +classes.tuple classes.tuple.parser combinators effects effects.parser +fry generic generic.parser generic.standard interpolate +io.streams.string kernel lexer locals.parser locals.rewrite.closures +locals.types make namespaces parser quotations sequences vocabs.parser +words words.symbol ; IN: functors ! This is a hack @@ -71,6 +71,14 @@ SYNTAX: `TUPLE: } case \ define-tuple-class parsed ; +SYNTAX: `SINGLETON: + scan-param parsed + \ define-singleton-class parsed ; + +SYNTAX: `MIXIN: + scan-param parsed + \ define-mixin-class parsed ; + SYNTAX: `M: scan-param parsed scan-param parsed @@ -134,6 +142,8 @@ DEFER: ;FUNCTOR delimiter : functor-words ( -- assoc ) H{ { "TUPLE:" POSTPONE: `TUPLE: } + { "SINGLETON:" POSTPONE: `SINGLETON: } + { "MIXIN:" POSTPONE: `MIXIN: } { "M:" POSTPONE: `M: } { "C:" POSTPONE: `C: } { ":" POSTPONE: `: } diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 75607b0258..3c5ac31d23 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -134,3 +134,19 @@ unit-test [ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test [ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test [ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test + +[ H{ { 1 2 } { 2 3 } } ] [ + { + H{ { 1 3 } } + H{ { 2 3 } } + H{ { 1 2 } } + } assoc-combine +] unit-test + +[ H{ { 1 7 } } ] [ + { + H{ { 1 2 } { 2 4 } { 5 6 } } + H{ { 1 3 } { 2 5 } } + H{ { 1 7 } { 5 6 } } + } assoc-refine +] unit-test \ No newline at end of file diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 62ab9f86ae..8b6809236c 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -129,6 +129,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : assoc-combine ( seq -- union ) H{ } clone [ dupd update ] reduce ; +: assoc-refine ( seq -- assoc ) + [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ; + : assoc-diff ( assoc1 assoc2 -- diff ) [ nip key? not ] curry assoc-filter ;