(* Pasted from Pottier's PP compiler *)
(* This module implements a data structure for interference graphs.
It provides functions that help construct, transform and inspect
interference graphs. *)
(* ------------------------------------------------------------------------- *)
(* Vertices are represented as integers. We need sets of vertices, maps over
vertices, maps of vertices to nonempty sets of vertices, maps of vertices
to nonempty sets of hardware registers, and priority sets over vertices. *)
module Vertex = struct
module V = struct
type t = int
let compare = compare
end
include V
module Set = Set.Make(V)
module Map = MyMap.Make(V)
end
module VertexSetMap =
SetMap.MakeHomo(Vertex.Set)(Vertex.Map)
module I8051RegisterSetMap =
SetMap.MakeHetero(I8051.RegisterSet)(Vertex.Map)
module PrioritySet =
PrioritySet.Make(Vertex)
(* ------------------------------------------------------------------------- *)
(* Each vertex maps to a set of pseudo-registers, which initially is a
singleton set, but can grow due to coalescing. Conversely, each
pseudo-register maps to a single vertex. *)
module RegMap : sig
type t
(* [empty] is the empty map. *)
val empty: t
(* [forward] maps a vertex to a set of pseudo-registers. *)
val forward: Vertex.t -> t -> Register.Set.t
(* [backward] maps a pseudo-register to a vertex. *)
val backward: Register.t -> t -> Vertex.t
(* [add r v m] adds a relation between pseudo-register [r] and
vertex [v], both of which are assumed fresh. *)
val add: Register.t -> Vertex.t -> t -> t
(* [fold f m accu] folds over all vertices. *)
val fold: (Vertex.t -> Register.Set.t -> 'a -> 'a) -> t -> 'a -> 'a
(* [coalesce x y m] coalesces vertices [x] and [y]. Vertex [x] is
removed and the pseudo-registers associated with it become
associated with [y] instead. *)
val coalesce: Vertex.t -> Vertex.t -> t -> t
(* [remove x m] removes vertex [x]. The pseudo-registers associated
with [x] disappear. *)
val remove: Vertex.t -> t -> t
(* [restrict] keeps only those vertices that satisfy predicate [p]. *)
val restrict: (Vertex.t -> bool) -> t -> t
end = struct
type t = {
forward: Register.Set.t Vertex.Map.t;
backward: Vertex.t Register.Map.t
}
let empty = {
forward = Vertex.Map.empty;
backward = Register.Map.empty
}
let forward v m =
Vertex.Map.find v m.forward
let backward r m =
try
Register.Map.find r m.backward
with Not_found ->
assert false (* bad pseudo-register *)
let add r v m = {
forward = Vertex.Map.add v (Register.Set.singleton r) m.forward;
backward = Register.Map.add r v m.backward
}
let fold f m accu =
Vertex.Map.fold f m.forward accu
let coalesce x y m =
let rx, forward = Vertex.Map.find_remove x m.forward in
let forward = Vertex.Map.update y (Register.Set.union rx) forward in
let backward =
Register.Set.fold (fun r backward ->
Register.Map.add r y backward
) rx m.backward
in
{
forward = forward;
backward = backward
}
let remove x m =
let rx, forward = Vertex.Map.find_remove x m.forward in
let backward = Register.Set.fold Register.Map.remove rx m.backward in
{
forward = forward;
backward = backward
}
let restrict p m = {
forward = Vertex.Map.restrict p m.forward;
backward = Register.Map.restrict (fun r -> p (backward r m)) m.backward
}
end
(* ------------------------------------------------------------------------- *)
(* Graphs. *)
type graph = {
(* A two-way correspondence between vertices and pseudo-registers.
This data structure is also used to keep a record of the set of
all vertices. *)
regmap: RegMap.t;
(* Interference edges between two vertices: ``these two vertices
cannot receive the same color''. *)
ivv: VertexSetMap.t;
(* Interference edges between a vertex and a hardware register:
``this vertex cannot receive this color''. *)
ivh: I8051RegisterSetMap.t;
(* Preference edges between two vertices: ``these two vertices
should preferably receive the same color''. *)
pvv: VertexSetMap.t;
(* Preference edges between a vertex and a hardware register:
``this vertex should preferably receive this color''. *)
pvh: I8051RegisterSetMap.t;
(* The degree of each vertex [v], that is, the number of vertices
and hardware registers that [v] interferes with, is recorded at
all times. We use a ``priority set'' so as to be able to
efficiently find a vertex of minimum degree. *)
degree: PrioritySet.t;
(* The degree of each *non-move-related* vertex [v]. This
information is partially redundant with the [degree] field
above. It is nevertheless required in order to be able to
efficiently find a *non-move-related* vertex of minimum
degree. *)
nmr: PrioritySet.t;
}
(* ------------------------------------------------------------------------- *)
(* Our graphs are made up of two subgraphs: the subgraph formed by the
interference edges alone and the one formed by the preference edges
alone.
In order to allow more code sharing, we define functions that allow
dealing with a single subgraph at a time. They provide operations
such as inspecting the neighbors of a vertex, adding edges,
removing edges, coalescing two vertices, removing a vertex, etc.
We first define functions that deal with a ``generic'' subgraph,
then (via inheritance) specialize them to deal with the
interference subgraph and the preference subgraph with their
specific features. *)
class virtual subgraph = object (self)
(* These methods provide access to the fields of the [graph] data
structure that define the subgraph of interest. All data is
stored in the [graph] data structure. The object [self] has no
state and holds no data. *)
method virtual getvv: graph -> VertexSetMap.t
method virtual setvv: graph -> VertexSetMap.t -> graph
method virtual getvh: graph -> I8051RegisterSetMap.t
method virtual setvh: graph -> I8051RegisterSetMap.t -> graph
(* Accessing the neighbors of a vertex and testing whether edges
exist. *)
method neighborsv graph v =
VertexSetMap.find v (self#getvv graph)
method existsvv graph v1 v2 =
Vertex.Set.mem v1 (self#neighborsv graph v2)
method neighborsh graph v =
I8051RegisterSetMap.find v (self#getvh graph)
method existsvh graph v h =
I8051.RegisterSet.mem h (self#neighborsh graph v)
(* [degree graph v] is the degree of vertex [v] with respect to the
subgraph. *)
method degree graph v =
Vertex.Set.cardinal (self#neighborsv graph v) + I8051.RegisterSet.cardinal (self#neighborsh graph v)
(* [hwregs graph] is the set of all hardware registers mentioned in
the subgraph. *)
method hwregs graph =
let union _ = I8051.RegisterSet.union in
Vertex.Map.fold union (self#getvh graph) I8051.RegisterSet.empty
(* [iter graph fvv fvh] iterates over all edges in the subgraph.
Vertex-to-vertex edges are presented only once. *)
method iter graph fvv fvh =
Vertex.Map.iter (fun vertex neighbors ->
Vertex.Set.iter (fun neighbor ->
if vertex < neighbor then
fvv vertex neighbor
) neighbors
) (self#getvv graph);
Vertex.Map.iter (fun vertex neighbors ->
I8051.RegisterSet.iter (fun neighbor ->
fvh vertex neighbor
) neighbors
) (self#getvh graph)
(* [mkvv graph v1 v2] adds an edge between vertices [v1] and [v2]. *)
method mkvv graph v1 v2 =
if v1 = v2 then
graph (* avoid creating self-edge *)
else if self#existsvv graph v1 v2 then
graph (* avoid re-adding an existing edge *)
else
self#mkvvi graph v1 v2
method mkvvi graph v1 v2 =
self#setvv graph (VertexSetMap.mkbiedge v1 v2 (self#getvv graph))
(* [rmvv graph v1 v2] removes an edge between vertices [v1] and [v2].
[rmvvifx] removes an edge if it exists. *)
method rmvv graph v1 v2 =
assert (self#existsvv graph v1 v2);
self#setvv graph (VertexSetMap.rmbiedge v1 v2 (self#getvv graph))
method rmvvifx graph v1 v2 =
if self#existsvv graph v1 v2 then
self#rmvv graph v1 v2
else
graph
(* [mkvh graph v h] adds an edge between vertex [v] and hardware
register [h]. *)
method mkvh graph v h =
if self#existsvh graph v h then
graph (* avoid re-adding an existing edge *)
else
self#mkvhi graph v h
method mkvhi graph v h =
self#setvh graph (I8051RegisterSetMap.update v (I8051.RegisterSet.add h) (self#getvh graph))
(* [rmvh v h] removes an edge between vertex [v] and hardware
register [h]. [rmvhifx] removes an edge if it exists. *)
method rmvh graph v h =
assert (self#existsvh graph v h);
self#setvh graph (I8051RegisterSetMap.update v (I8051.RegisterSet.remove h) (self#getvh graph))
method rmvhifx graph v h =
if self#existsvh graph v h then
self#rmvh graph v h
else
graph
(* [coalesce graph x y] turns every neighbor [w] or [h] of [x] into
a neighbor of [y] instead. [w] ranges over both vertices and
hardware registers. *)
method coalesce graph x y =
let graph =
Vertex.Set.fold (fun w graph ->
self#mkvv (self#rmvv graph x w) y w
) (self#neighborsv graph x) graph
in
let graph =
I8051.RegisterSet.fold (fun h graph ->
self#mkvh (self#rmvh graph x h) y h
) (self#neighborsh graph x) graph
in
graph
(* [coalesceh graph x h] turns every neighbor [w] of [x] into a
neighbor of [h] instead. [w] ranges over both vertices and
hardware registers. Edges between two hardware registers are not
recorded. *)
method coalesceh graph x h =
let graph =
Vertex.Set.fold (fun w graph ->
self#mkvh (self#rmvv graph x w) w h
) (self#neighborsv graph x) graph
in
let graph =
I8051.RegisterSet.fold (fun k graph ->
self#rmvh graph x k
) (self#neighborsh graph x) graph
in
graph
(* [remove graph x] removes all edges carried by vertex [x]. *)
method remove graph x =
let graph =
Vertex.Set.fold (fun w graph ->
self#rmvv graph x w
) (self#neighborsv graph x) graph
in
let graph =
I8051.RegisterSet.fold (fun h graph ->
self#rmvh graph x h
) (self#neighborsh graph x) graph
in
graph
end
(* ------------------------------------------------------------------------- *)
(* The interference subgraph.
This is a subgraph with the following specific features: (1) the
degree of every vertex is recorded in the [degree] field of the
[graph] data structure; (2) the degree of every non-move-related
vertex is recorded in the [nmr] field of the [graph] data
structure; (3) creating an edge in the interference subgraph
automatically destroys a corresponding edge in the preference
subgraph. *)
class interference (preference : preference Lazy.t) = object (self)
inherit subgraph as super
method getvv graph = graph.ivv
method setvv graph m = { graph with ivv = m }
method getvh graph = graph.ivh
method setvh graph m = { graph with ivh = m }
(* Override the edge creation and destruction methods. *)
method mkvvi graph v1 v2 =
let graph = super#mkvvi graph v1 v2 in
let graph = (Lazy.force preference)#rmvvifx graph v1 v2 in (* do not constrain an existing preference edge *)
{ graph with
degree = PrioritySet.increment v1 1 (PrioritySet.increment v2 1 graph.degree);
nmr = PrioritySet.incrementifx v1 1 (PrioritySet.incrementifx v2 1 graph.nmr);
}
method rmvv graph v1 v2 =
let graph = super#rmvv graph v1 v2 in
{ graph with
degree = PrioritySet.increment v1 (-1) (PrioritySet.increment v2 (-1) graph.degree);
nmr = PrioritySet.incrementifx v1 (-1) (PrioritySet.incrementifx v2 (-1) graph.nmr);
}
method mkvhi graph v h =
let graph = super#mkvhi graph v h in
let graph = (Lazy.force preference)#rmvhifx graph v h in (* do not constrain an existing preference edge *)
{ graph with
degree = PrioritySet.increment v 1 graph.degree;
nmr = PrioritySet.incrementifx v 1 graph.nmr;
}
method rmvh graph v h =
let graph = super#rmvh graph v h in
{ graph with
degree = PrioritySet.increment v (-1) graph.degree;
nmr = PrioritySet.incrementifx v (-1) graph.nmr;
}
end
(* ------------------------------------------------------------------------- *)
(* The preference subgraph.
This is a subgraph with the following specific features: (1) an
edge in the preference subgraph cannot be created if a
corresponding edge exists in the interference subgraph; (2) adding
an edge can make a vertex move-related, which requires taking that
vertex out of the [nmr] set; conversely, removing an edge can make
a vertex non-move-related, which requires adding that vertex to the
[nmr] set. *)
and preference (interference : interference Lazy.t) = object (self)
inherit subgraph as super
method getvv graph = graph.pvv
method setvv graph m = { graph with pvv = m }
method getvh graph = graph.pvh
method setvh graph m = { graph with pvh = m }
(* [nmr graph v] tells whether vertex [v] is non-move-related. *)
method nmr graph v =
Vertex.Set.is_empty (self#neighborsv graph v) &&
I8051.RegisterSet.is_empty (self#neighborsh graph v)
(* [mkcheck graph v] moves [v] out of the [nmr] set if [v] is
non-move-related. *)
method mkcheck graph v =
if self#nmr graph v then
{ graph with
nmr = PrioritySet.remove v graph.nmr }
else
graph
(* Override the edge creation methods. *)
method mkvvi graph v1 v2 =
if (Lazy.force interference)#existsvv graph v1 v2 then
graph (* avoid creating constrained preference edge *)
else
let graph = self#mkcheck graph v1 in
let graph = self#mkcheck graph v2 in
super#mkvvi graph v1 v2
method mkvhi graph v h =
if (Lazy.force interference)#existsvh graph v h then
graph (* avoid creating constrained preference edge *)
else
let graph = self#mkcheck graph v in
super#mkvhi graph v h
(* [rmcheck graph v] moves [v] into the [nmr] set if [v] is
non-move-related. *)
method rmcheck graph v =
if self#nmr graph v then
{ graph with
nmr = PrioritySet.add v (PrioritySet.priority v graph.degree) graph.nmr
}
else
graph
(* Override the edge destruction methods. *)
method rmvv graph v1 v2 =
let graph = super#rmvv graph v1 v2 in
let graph = self#rmcheck graph v1 in
let graph = self#rmcheck graph v2 in
graph
method rmvh graph v h =
let graph = super#rmvh graph v h in
let graph = self#rmcheck graph v in
graph
end
(* ------------------------------------------------------------------------- *)
(* Because the interference and preference subgraphs are mutually
referential, a recursive definition is required. It is made
somewhat inelegant by Objective Caml's insistence on using the
[Lazy] mechanism. *)
let rec interference = lazy (new interference preference)
and preference = lazy (new preference interference)
let interference = Lazy.force interference
let preference = Lazy.force preference
(* ------------------------------------------------------------------------- *)
(* Inspecting interference graphs. *)
(* [ipp graph v] is the set of vertices that the vertex [v] interferes
with. *)
let ipp graph v =
interference#neighborsv graph v
(* [iph graph v] is the set of hardware registers that the vertex [v]
interferes with. *)
let iph graph v =
interference#neighborsh graph v
(* [ppp graph v] is the set of vertices that should preferably be
assigned the same color as the vertex [v]. *)
let ppp graph v =
preference#neighborsv graph v
(* [pph graph v] is the set of hardware registers that [v] should
preferably be assigned. *)
let pph graph v =
preference#neighborsh graph v
(* [degree graph v] is the degree of the vertex [v], that is, the number
of vertices and hardware registers that [v] interferes with. *)
let degree graph v =
PrioritySet.priority v graph.degree
(* [lowest graph] returns [Some (v, d)], where the vertex [v] has
minimum degree [d], or returns [None] if the graph is empty. *)
let lowest graph =
PrioritySet.lowest graph.degree
(* [lowest_non_move_related graph] returns [Some (v, d)], where the
vertex [v] has minimum degree [d] among the vertices that are not
move-related, or returns [None] if all vertices are move-related. A
vertex is move-related if it carries a preference edge. *)
let lowest_non_move_related graph =
PrioritySet.lowest graph.nmr
(* [fold f graph accu] folds over all vertices. *)
let fold f graph accu =
RegMap.fold (fun v _ accu -> f v accu) graph.regmap accu
(* [minimum f graph] returns a vertex [v] such that the value of [f x]
is minimal. The values returned by [f] are compared using Objective
Caml's generic comparison operator [<]. If the graph is empty,
[None] is returned. *)
let minimum f graph =
match
fold (fun w accu ->
let dw = f w in
match accu with
| None ->
Some (dw, w)
| Some (dv, v) ->
if dw < dv then
Some (dw, w)
else
accu
) graph None
with
| None ->
None
| Some (_, v) ->
Some v
(* [pppick graph p] returns an arbitrary preference edge that
satisfies the predicate [p], if the graph contains one. *)
type ppedge =
Vertex.t * Vertex.t
let pppick graph p =
VertexSetMap.pick graph.pvv p
(* [phpick graph p] returns an arbitrary preference edge that
satisfies the predicate [p], if the graph contains one. *)
type phedge =
Vertex.t * I8051.register
let phpick graph p =
I8051RegisterSetMap.pick graph.pvh p
(* ------------------------------------------------------------------------- *)
(* Constructing interference graphs. *)
(* [create regs] creates an interference graph whose vertices are
the pseudo-registers [regs] and that does not have any edges. *)
let create regs =
let (_ : int), regmap, degree =
Register.Set.fold (fun r (v, regmap, degree) ->
v+1,
RegMap.add r v regmap,
PrioritySet.add v 0 degree
) regs (0, RegMap.empty, PrioritySet.empty)
in
{
regmap = regmap;
ivv = Vertex.Map.empty;
ivh = Vertex.Map.empty;
pvv = Vertex.Map.empty;
pvh = Vertex.Map.empty;
degree = degree;
nmr = degree
}
(* [lookup graph r] returns the graph vertex associated with
pseudo-register [r]. *)
let lookup graph r =
RegMap.backward r graph.regmap
(* Conversely, [registers graph v] returns the set of pseudo-registers
associated with vertex [v]. *)
let registers graph v =
RegMap.forward v graph.regmap
(* [mkipp graph regs1 regs2] adds interference edges between all pairs
of pseudo-registers [r1] and [r2], where [r1] ranges over [regs1],
[r2] ranges over [regs2], and [r1] and [r2] are distinct. *)
let mkipp graph regs1 regs2 =
Register.Set.fold (fun r1 graph ->
let v1 = lookup graph r1 in
Register.Set.fold (fun r2 graph ->
interference#mkvv graph v1 (lookup graph r2)
) regs2 graph
) regs1 graph
(* [mkiph graph regs hwregs] adds interference edges between all pairs
of a pseudo-register [r] and a hardware register [hwr], where [r]
ranges over [regs] and [hwr] ranges over [hwregs]. *)
let mkiph graph regs hwregs =
Register.Set.fold (fun r graph ->
let v = lookup graph r in
I8051.RegisterSet.fold (fun h graph ->
interference#mkvh graph v h
) hwregs graph
) regs graph
(* [mki graph regs1 regs2] adds interference edges between all pairs
of (pseudo- or hardware) registers [r1] and [r2], where [r1] ranges
over [regs1], [r2] ranges over [regs2], and [r1] and [r2] are
distinct. *)
let mki graph (regs1, hwregs1) (regs2, hwregs2) =
let graph = mkipp graph regs1 regs2 in
let graph = mkiph graph regs1 hwregs2 in
let graph = mkiph graph regs2 hwregs1 in
graph
(* [mkppp graph r1 r2] adds a preference edge between the
pseudo-registers [r1] and [r2]. *)
let mkppp graph r1 r2 =
let v1 = lookup graph r1
and v2 = lookup graph r2 in
let graph = preference#mkvv graph v1 v2 in
graph
(* [mkpph graph r h] adds a preference edge between the
pseudo-register [r] and the hardware register [h]. *)
let mkpph graph r h =
let v = lookup graph r in
let graph = preference#mkvh graph v h in
graph
(* ------------------------------------------------------------------------- *)
(* Displaying interference graphs. *)
open Printf
let hwregs graph =
I8051.RegisterSet.union (interference#hwregs graph) (preference#hwregs graph)
let print_vertex graph v =
Register.Set.print (registers graph v)
let print f graph =
fprintf f "graph G {\n";
(* fprintf f "size=\"6, 3\";\n"; (* in inches *)*)
fprintf f "orientation = landscape;\n";
fprintf f "rankdir = LR;\n";
fprintf f "ratio = compress;\n\n"; (* compress or fill or auto *)
RegMap.fold (fun vertex regs () ->
fprintf f "r%d [ label=\"%s\" ] ;\n" vertex (Register.Set.print regs)
) graph.regmap ();
I8051.RegisterSet.iter (fun hwr ->
let name = I8051.print_register hwr in
fprintf f "hwr%s [ label=\"$%s\" ] ;\n" name name
) (hwregs graph);
interference#iter graph
(fun vertex neighbor ->
fprintf f "r%d -- r%d ;\n" vertex neighbor)
(fun vertex neighbor ->
fprintf f "r%d -- hwr%s ;\n" vertex (I8051.print_register neighbor));
preference#iter graph
(fun vertex neighbor ->
fprintf f "r%d -- r%d [ style = dashed ] ;\n" vertex neighbor)
(fun vertex neighbor ->
fprintf f "r%d -- hwr%s [ style = dashed ] ;\n" vertex (I8051.print_register neighbor));
fprintf f "\n}\n"
(* ------------------------------------------------------------------------- *)
(* Coalescing. *)
(* [coalesce graph v1 v2] is a new graph where the vertices [v1] and [v2]
are coalesced. The new coalesced vertex is known under the name [v2]. *)
let coalesce graph x y =
assert (x <> y); (* attempt to coalesce one vertex with itself *)
assert (not (interference#existsvv graph x y)); (* attempt to coalesce two interfering vertices *)
(* Perform coalescing in the two subgraphs. *)
let graph = interference#coalesce graph x y in
let graph = preference#coalesce graph x y in
(* Remove [x] from all tables. *)
{
graph with
regmap = RegMap.coalesce x y graph.regmap;
ivh = Vertex.Map.remove x graph.ivh;
pvh = Vertex.Map.remove x graph.pvh;
degree = PrioritySet.remove x graph.degree;
nmr = PrioritySet.remove x graph.nmr;
}
(* [coalesceh graph v h] coalesces the vertex [v] with the hardware register
[h]. This produces a new graph where [v] no longer exists and all edges
leading to [v] are replaced with edges leading to [h]. *)
let coalesceh graph x h =
assert (not (interference#existsvh graph x h)); (* attempt to coalesce interfering entities *)
(* Perform coalescing in the two subgraphs. *)
let graph = interference#coalesceh graph x h in
let graph = preference#coalesceh graph x h in
(* Remove [x] from all tables. *)
{
graph with
regmap = RegMap.remove x graph.regmap;
ivh = Vertex.Map.remove x graph.ivh;
pvh = Vertex.Map.remove x graph.pvh;
degree = PrioritySet.remove x graph.degree;
nmr = PrioritySet.remove x graph.nmr;
}
(* ------------------------------------------------------------------------- *)
(* [freeze graph x] is a new graph where all preference edges carried
by [x] are removed. *)
let freeze graph x =
preference#remove graph x
(* ------------------------------------------------------------------------- *)
(* Removal. *)
(* [remove graph v] is a new graph where vertex [v] is removed. *)
let remove graph v =
(* Remove all edges carried by [v]. *)
let graph = interference#remove graph v in
let graph = preference#remove graph v in
(* Remove [v] from all tables. *)
{
graph with
regmap = RegMap.remove v graph.regmap;
degree = PrioritySet.remove v graph.degree;
nmr = PrioritySet.remove v graph.nmr;
}
(* ------------------------------------------------------------------------- *)
(* [mkdeg graph] recomputes degree information from scratch. *)
let mkdeg graph =
let degree, nmr =
fold (fun v (degree, nmr) ->
let d = interference#degree graph v in
PrioritySet.add v d degree,
if preference#nmr graph v then PrioritySet.add v d nmr else nmr
) graph (PrioritySet.empty, PrioritySet.empty)
in
{ graph with
degree = degree;
nmr = nmr;
}
(* [restrict graph p] is a new graph where only those vertices that
satisfy predicate [p] are kept. The same effect could be obtained
by repeated application of [remove], but [restrict] is likely to be
more efficient if many vertices are removed. *)
let restrict graph p =
mkdeg {
graph with
regmap = RegMap.restrict p graph.regmap;
ivv = VertexSetMap.restrict p graph.ivv;
ivh = Vertex.Map.restrict p graph.ivh;
pvv = VertexSetMap.restrict p graph.pvv;
pvh = Vertex.Map.restrict p graph.pvh;
}
(* [droph graph] is a new graph where all information concerning hardware
registers has been dropped. *)
let droph graph =
mkdeg {
graph with
ivh = Vertex.Map.empty;
pvh = Vertex.Map.empty;
}