# dominator-tree-g.pkg
# Computation of the dominator tree representation from the
# control flow graph. I'm using the old algorithm by Lengauer and Tarjan.
#
# Note: to deal with machcode_controlflow_graph with endless loops,
# by default we assume instructions are postdominated by STOP.
#
# -- Allen Leung
# Compiled by:
#
src/lib/graph/graphs.lib### "God could not be everywhere, and
### therefore he made mothers."
###
### -- Rudyard Kipling
stipulate
package odg = oop_digraph; # oop_digraph is from
src/lib/graph/oop-digraph.pkg package rev = reversed_graph_view; # reversed_graph_view is from
src/lib/graph/revgraph.pkg package rwv = rw_vector; # rw_vector is from
src/lib/std/src/rw-vector.pkg# package node_set = bit_set; # bit_set is from
src/lib/graph/bit-set.pkgherein
# We get invoked from:
#
#
src/lib/compiler/back/low/frequencies/guess-machcode-loop-probabilities-g.pkg #
generic package dominator_tree_g (
# ================
#
meg: Make_Empty_Graph # Make_Empty_Graph is from
src/lib/graph/make-empty-graph.api )
: (weak) Dominator_Tree # Dominator_Tree is from
src/lib/graph/dominator-tree.api {
# Export to client packages:
#
package meg = meg;
exception DOMINATOR;
fun single_entry_of (odg::DIGRAPH g)
=
case (g.entries ())
#
[e] => e;
_ => raise exception DOMINATOR;
esac;
Node = odg::Node_Id;
Dom_Info (N, E, G)
=
INFO
{ mcg: odg::Digraph( N, E, G ),
edge_label: String,
levels_map: rw_vector::Rw_Vector( Int ),
preorder: Ref( Null_Or( rw_vector::Rw_Vector( Int ) ) ),
postorder: Ref( Null_Or( rw_vector::Rw_Vector( Int ) ) ),
entry_pos: Ref( Null_Or( rw_vector::Rw_Vector( Int ) ) ),
max_levels: Ref( Int )
};
Dominator_Tree (N,E,G) = odg::Digraph (N, Void, Dom_Info(N,E,G));
Postdominator_Tree (N,E,G) = odg::Digraph (N, Void, Dom_Info(N,E,G));
fun graph_info (odg::DIGRAPH dom) : Dom_Info( N, E, G )
=
dom.graph_info;
fun mcg (odg::DIGRAPH dom)
=
{ dom.graph_info -> INFO { mcg, ... };
mcg;
};
fun max_levels (odg::DIGRAPH dom)
=
{ dom.graph_info -> INFO { max_levels, ... };
#
*max_levels;
};
# This is the main Lengauer/Tarjan algorithm
#
fun tarjan_lengauer (name, edge_label) (orig_cfg, mcg'' as (odg::DIGRAPH mcg))
=
{ nnn = mcg.order ();
mmm = mcg.capacity ();
r = single_entry_of mcg'';
in_edges = mcg.in_edges;
next = mcg.next;
dfnum = rwv::make_rw_vector (mmm, -1);
vertex = rwv::make_rw_vector (nnn, -1);
parent = rwv::make_rw_vector (mmm, -1);
bucket = rwv::make_rw_vector (mmm, []) : Rw_Vector( List( Node ) );
semi = rwv::make_rw_vector (mmm, r);
ancestor = rwv::make_rw_vector (mmm, -1);
idom = rwv::make_rw_vector (mmm, r);
samedom = rwv::make_rw_vector (mmm, -1);
best = rwv::make_rw_vector (mmm, -1);
max_levels = REF 0;
levels_map = rwv::make_rw_vector (mmm,-1000000);
dom_info = INFO { mcg => orig_cfg,
edge_label,
levels_map,
preorder => REF NULL,
postorder => REF NULL,
entry_pos => REF NULL,
max_levels
};
my dom as odg::DIGRAPH domtree
=
meg::make_empty_graph
{
graph_name => name, # Arbitrary client name for graph, for human-display purposes.
graph_info => dom_info, # Arbitrary client value to associate with graph.
expected_node_count => nnn # Hint for initial sizing of internal graph vectors. This is not a hard limit.
};
# step 1
# Initialize semi dominators and parent map
fun dfs (p, n, nnn)
=
if (rwv::get (dfnum, n) == -1)
#
rwv::set (dfnum, n, nnn);
rwv::set (vertex, nnn, n);
rwv::set (parent, n, p);
dfs_succ (n, next n, nnn+1);
else
nnn;
fi
also
fun dfs_succ (p,[], nnn)
=>
nnn;
dfs_succ (p, n ! ns, nnn)
=>
dfs_succ (p, ns, dfs (p, n, nnn));
end
also
fun dfs_all (n ! ns, nnn)
=>
dfs_all (ns, dfs(-1, n, nnn));
dfs_all([], nnn)
=>
();
end;
non_roots
=
list::fold_backward
(\\ ((r', _), l)
=
if (r != r' ) r' ! l;
else l; fi)
[]
(mcg.nodes ());
dfs_all (non_roots, dfs(-1, r, 0));
# fun pr s = print (s + "\n")
# fun dumpArray title a =
# pr (title + ": " +
# string::cat (rwv::fold_backward
# (\\ (i, s) => int::to_string i ::( ) ! s) [] a))
#
# pr("root = " + int::to_string r)
# dumpArray "vertex" vertex
# dumpArray "dfnum" dfnum
# dumpArray "parent" parent
# Msg::printMessages (\\ _ => machcode_controlflow_graph::G.printGraph *msg::out_stream mcg)
fun link (p, n)
=
{ rwv::set (ancestor, n, p);
rwv::set (best, n, n);
};
fun ancestor_with_lowest_semi v
=
{ a = rwv::get (ancestor, v);
if (a != -1 and rwv::get (ancestor, a) != -1)
#
b = ancestor_with_lowest_semi a;
rwv::set (ancestor, v, rwv::get (ancestor, a));
if (rwv::get (dfnum, rwv::get (semi, b))
<
rwv::get (dfnum, rwv::get (semi, rwv::get (best, v)))
)
rwv::set (best, v, b);
fi;
fi;
u = rwv::get (best, v);
u == -1 ?? v
:: u;
};
# steps 2 and 3
# Compute vertex, bucket and semi maps
#
fun compute 0
=>
();
compute i
=>
{ n = rwv::get (vertex, i);
p = rwv::get (parent, n);
fun compute_semi ((v, n, _) ! rest, s)
=>
if (v == n)
compute_semi (rest, s);
else
s' =
if (rwv::get (dfnum, v)
<
rwv::get (dfnum, n)
)
v;
else
rwv::get (semi, ancestor_with_lowest_semi v);
fi;
s =
if (rwv::get (dfnum, s')
<
rwv::get (dfnum, s)
)
s';
else s;
fi;
compute_semi (rest, s);
fi;
compute_semi ([], s)
=>
s;
end;
if (p != -1)
#
s = compute_semi (in_edges n, p);
rwv::set (semi, n, s);
rwv::set (bucket, s, n ! rwv::get (bucket, s));
link (p, n);
apply
(\\ v
=
{ y = ancestor_with_lowest_semi v;
if (rwv::get (semi, y)
==
rwv::get (semi, v)
)
rwv::set (idom, v, p);
else rwv::set (samedom, v, y);
fi;
})
(rwv::get (bucket, p));
rwv::set (bucket, p,[]);
fi;
compute (i - 1);
};
end; # fun compute
compute (nnn - 1);
# dumpArray "semi" idom
# dumpArray "idom" idom
# Step 4: Update dominators:
#
fun update_idoms i
=
if (i < nnn)
#
n = rwv::get (vertex, i);
if (rwv::get (samedom, n) != -1)
#
rwv::set (idom, n, rwv::get (idom, rwv::get (samedom, n)));
fi;
update_idoms (i+1);
fi;
update_idoms 1;
# dumpArray "idom" idom
# Create the nodes/edges
# of the dominator tree:
#
fun build_graph (i, max_level)
=
if (i < nnn)
#
v = rwv::get (vertex, i);
domtree.add_node (v, mcg.node_info v);
if (v != r)
#
w = rwv::get (idom, v);
l = rwv::get (levels_map, w)+1;
rwv::set (levels_map, v, l);
domtree.add_edge (w, v, ());
build_graph
(
i+1,
l >= max_level ?? l
:: max_level
);
else
rwv::set (levels_map, v, 0);
build_graph (i+1, max_level);
fi;
else
max_level;
fi;
max = build_graph (0, 1);
max_levels := max+1;
domtree.set_entries [r];
# Msg::printMessages (\\ _ = odg::printGraph *msg::out_stream domtree);
dom;
};
# The algorithm specialized to making dominators and postdominators
fun make_dominator mcg
=
tarjan_lengauer("Dom", "dom") (mcg, mcg);
fun make_postdominator mcg
=
tarjan_lengauer("PDom", "pdom") (mcg, rev::rev_view mcg);
# Methods
# Does i immediately dominate j?
#
fun immediately_dominates (odg::DIGRAPH d) (i, j)
=
case (d.in_edges j)
(k, _, _) ! _ => i == k;
_ => FALSE;
esac;
# Immediate dominator of n:
#
fun idom (odg::DIGRAPH d) n
=
case (d.in_edges n)
(n, _, _) ! _ => n;
_ => -1;
esac;
# Nodes that n immediately dominates:
#
fun idoms (odg::DIGRAPH d)
=
d.next;
# Nodes that n dominates:
#
fun doms (odg::DIGRAPH d)
=
\\ n = subtree ([n], [])
where
fun subtree ( [], s) => s;
subtree (n ! ns, s) => subtree (d.next n, subtree (ns, n ! s));
end;
end;
fun pre_post_orders (g as odg::DIGRAPH dom)
=
{ my INFO { preorder, postorder, ... }
=
dom.graph_info;
# Compute the preorder/postorder numbers
#
fun compute_them ()
=
{ nnn = dom.capacity ();
r = single_entry_of g;
pre = rwv::make_rw_vector (nnn,-1000000);
post = rwv::make_rw_vector (nnn,-1000000);
fun compute_numbering (preorder, postorder, n)
=
{ rwv::set (pre, n, preorder);
my (preorder', postorder')
=
compute_numbering'(preorder+1, postorder, dom.out_edges n);
rwv::set (post, n, postorder');
(preorder', postorder'+1);
}
also
fun compute_numbering'(preorder, postorder,[])
=>
(preorder, postorder);
compute_numbering'(preorder, postorder, (_, n, _) ! es)
=>
{ my (preorder', postorder')
=
compute_numbering (preorder, postorder, n);
my (preorder', postorder')
=
compute_numbering'(preorder', postorder', es);
(preorder', postorder');
};
end;
compute_numbering (0, 0, r) ;
preorder := THE pre;
postorder := THE post;
(pre, post);
};
case (*preorder, *postorder)
(THE pre, THE post) => (pre, post);
_ => compute_them();
esac;
};
# Level
#
fun level (odg::DIGRAPH d)
=
{ my INFO { levels_map, ... }
=
d.graph_info;
\\ i = rwv::get (levels_map, i);
};
# Entry position:
#
fun entry_pos (g as odg::DIGRAPH d)
=
{ my INFO { entry_pos, ... } = d.graph_info;
case *entry_pos
#
THE t => t;
NULL
=>
{ entry = single_entry_of g;
nnn = d.capacity ();
t = rwv::make_rw_vector (nnn, entry);
fun init (x, y)
=
{ rwv::set (t, x, y);
apply
(\\ z = init (z, y))
(d.next x);
};
entry_pos := THE t;
apply
(\\ z = init (z, z))
(d.next entry);
t;
};
esac;
};
# Least common ancestor
#
fun lca (dom as odg::DIGRAPH d) (a, b)
=
{ l_a = level dom a;
l_b = level dom b;
fun idom i
=
case (d.in_edges i)
(j, _, _) ! _
=>
j;
[] =>
raise exception DIE "dominator_tree: lca: idom: []";
esac;
fun up_a (a, l_a) = if (l_a > l_b ) up_a (idom a, l_a - 1); else a; fi;
fun up_b (b, l_b) = if (l_b > l_a ) up_b (idom b, l_b - 1); else b; fi;
a = up_a (a, l_a);
b = up_b (b, l_b);
fun up_both (a, b)
=
if (a == b)
a;
else
up_both (idom a, idom b);
fi;
up_both (a, b);
};
# is x and ancestor of y in d?
# This is true iff PREORDER x <= PREORDER y and
# POSTORDER x >= POSTORDER y
#
fun dominates dom
=
{ my (pre, post)
=
pre_post_orders dom;
\\ (x, y)
=
{ a = rwv::get (pre, x);
b = rwv::get (post, x);
c = rwv::get (pre, y);
d = rwv::get (post, y);
a <= c and b >= d;
};
};
fun strictly_dominates dom
=
{ my (pre, post)
=
pre_post_orders dom;
\\ (x, y)
=
{ a = rwv::get (pre, x);
b = rwv::get (post, x);
c = rwv::get (pre, y);
d = rwv::get (post, y);
a < c and b > d;
};
};
fun control_equivalent (dom, pdom)
=
{ dom = dominates dom;
pdom = dominates pdom;
\\ (x, y)
=
dom (x, y) and pdom (y, x) or dom (y, x) and pdom (x, y);
};
# control equivalent partitions
# two nodes a and b are control equivalent iff
# a dominates b and b postdominates a (or vice versa)
# We use the following property of dominators to avoid wasteful work:
# If i dom j dom k and j not pdom i then
# k not pdom i
# This algorithm runs in O (n)
#
fun control_equivalent_partitions (odg::DIGRAPH d, pdom)
=
{ postdominates = dominates pdom;
fun walk_dom ([], s)
=>
s;
walk_dom (n ! waiting, s)
=>
{ my (waiting, s, s')
=
find_equiv (n, d.out_edges n, waiting, s,[n]);
walk_dom (waiting, s' ! s);
};
end
also
fun find_equiv (i,[], waiting, s, s')
=>
(waiting, s, s');
find_equiv (i, (_, j, _) ! es, waiting, s, s')
=>
if (postdominates (j, i))
#
my (waiting, s, s')
=
find_equiv (i, es, waiting, s, j ! s');
find_equiv (i, d.out_edges j, waiting, s, s');
else
find_equiv (i, es, j ! waiting, s, s');
fi;
end;
equiv_sets = walk_dom (d.entries (),[]);
equiv_sets;
};
fun levels_map (odg::DIGRAPH dom)
=
{ my INFO { levels_map, ... }
=
dom.graph_info;
levels_map;
};
fun idoms_map (odg::DIGRAPH dom)
=
{ idoms = rwv::make_rw_vector (dom.capacity (),-1);
dom.forall_edges
(\\ (i, j, _) = rwv::set (idoms, j, i));
idoms;
};
};
end;