! 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.predecessors compiler.cfg ;
+! See https://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators.short-circuit
+compiler.cfg.predecessors compiler.cfg.rpo
+compiler.cfg.utilities deques dlists functors kernel lexer
+namespaces sequences ;
IN: compiler.cfg.dataflow-analysis
GENERIC: join-sets ( sets bb dfa -- set )
GENERIC: block-order ( cfg dfa -- bbs )
GENERIC: successors ( bb dfa -- seq )
GENERIC: predecessors ( bb dfa -- seq )
+GENERIC: ignore-block? ( bb dfa -- ? )
<PRIVATE
:: compute-in-set ( bb out-sets dfa -- set )
! Only consider initialized sets.
- bb kill-block?>> [ f ] [
+ bb dfa ignore-block? [ f ] [
bb dfa predecessors
[ out-sets key? ] filter
[ out-sets at ] map
bb in-sets maybe-set-at ; inline
:: compute-out-set ( bb in-sets dfa -- set )
- bb kill-block?>> [ f ] [ bb in-sets at bb dfa transfer-set ] if ;
+ bb dfa ignore-block? [ f ] [ bb in-sets at bb dfa transfer-set ] if ;
:: 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
+: update-in/out-set ( bb in-sets out-sets dfa -- ? )
+ { [ update-in-set ] [ update-out-set ] } 4 n&& ;
+
+:: dfa-step ( bb in-sets out-sets dfa -- bbs )
+ bb in-sets out-sets dfa update-in/out-set bb dfa successors { } ? ;
:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
- cfg needs-predecessors drop
H{ } clone :> in-sets
H{ } clone :> out-sets
- cfg dfa <dfa-worklist> :> work-list
- work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
+ cfg needs-predecessors
+ cfg dfa <dfa-worklist>
+ [ in-sets out-sets dfa dfa-step ] slurp/replenish-deque
in-sets
out-sets ; inline
-M: dataflow-analysis join-sets 2drop assoc-refine ;
+M: dataflow-analysis join-sets 2drop assoc-intersect-all ;
+M: dataflow-analysis ignore-block? drop kill-block?>> ;
-FUNCTOR: define-analysis ( name -- )
+<FUNCTOR: define-analysis ( name -- )
-name-analysis DEFINES-CLASS ${name}-analysis
+name DEFINES-CLASS ${name}
name-ins DEFINES ${name}-ins
name-outs DEFINES ${name}-outs
name-in DEFINES ${name}-in
WHERE
-SINGLETON: name-analysis
+SINGLETON: name
SYMBOL: name-ins
: name-out ( bb -- set ) name-outs get at ;
-;FUNCTOR
+;FUNCTOR>
! ! ! Forward dataflow analysis
M: forward-analysis successors drop successors>> ;
M: forward-analysis predecessors drop predecessors>> ;
-FUNCTOR: define-forward-analysis ( name -- )
+<FUNCTOR: define-forward-analysis ( name -- )
-name-analysis IS ${name}-analysis
+name IS ${name}
name-ins IS ${name}-ins
name-outs IS ${name}-outs
compute-name-sets DEFINES compute-${name}-sets
WHERE
-INSTANCE: name-analysis forward-analysis
+INSTANCE: name forward-analysis
: compute-name-sets ( cfg -- )
- name-analysis run-dataflow-analysis
+ name run-dataflow-analysis
[ name-ins set ] [ name-outs set ] bi* ;
-;FUNCTOR
+;FUNCTOR>
! ! ! Backward dataflow analysis
M: backward-analysis successors drop predecessors>> ;
M: backward-analysis predecessors drop successors>> ;
-FUNCTOR: define-backward-analysis ( name -- )
+<FUNCTOR: define-backward-analysis ( name -- )
-name-analysis IS ${name}-analysis
+name IS ${name}
name-ins IS ${name}-ins
name-outs IS ${name}-outs
compute-name-sets DEFINES compute-${name}-sets
WHERE
-INSTANCE: name-analysis backward-analysis
+INSTANCE: name backward-analysis
: compute-name-sets ( cfg -- )
- \ name-analysis run-dataflow-analysis
+ \ name run-dataflow-analysis
[ name-outs set ] [ name-ins set ] bi* ;
-;FUNCTOR
+;FUNCTOR>
PRIVATE>