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 ;