src/utilities/interference.ml

   1 (* Pasted from Pottier's PP compiler *)
   2
   3 (* This module implements a data structure for interference graphs.
   4    It provides functions that help construct, transform and inspect
   5    interference graphs. *)
   6
   7 (* ------------------------------------------------------------------------- *)
   8
   9 (* Vertices are represented as integers. We need sets of vertices, maps over
  10    vertices, maps of vertices to nonempty sets of vertices, maps of vertices
  11    to nonempty sets of hardware registers, and priority sets over vertices. *)
  12
  13 module Vertex = struct
  14
  15   module V = struct
  16     type t = int
  17     let compare = compare
  18   end
  19
  20   include V
  21
  22   module Set = Set.Make(V)
  23
  24   module Map = MyMap.Make(V)
  25
  26 end
  27
  28 module VertexSetMap =
  29   SetMap.MakeHomo(Vertex.Set)(Vertex.Map)
  30
  31 module I8051RegisterSetMap =
  32   SetMap.MakeHetero(I8051.RegisterSet)(Vertex.Map)
  33
  34 module PrioritySet =
  35   PrioritySet.Make(Vertex)
  36
  37 (* ------------------------------------------------------------------------- *)
  38
  39 (* Each vertex maps to a set of pseudo-registers, which initially is a
  40    singleton set, but can grow due to coalescing. Conversely, each
  41    pseudo-register maps to a single vertex. *)
  42
  43 module RegMap : sig
  44
  45   type t
  46
  47   (* [empty] is the empty map. *)
  48
  49   val empty: t
  50
  51   (* [forward] maps a vertex to a set of pseudo-registers. *)
  52
  53   val forward: Vertex.t -> t -> Register.Set.t
  54
  55   (* [backward] maps a pseudo-register to a vertex. *)
  56
  57   val backward: Register.t -> t -> Vertex.t
  58
  59   (* [add r v m] adds a relation between pseudo-register [r] and
  60      vertex [v], both of which are assumed fresh. *)
  61
  62   val add: Register.t -> Vertex.t -> t -> t
  63
  64   (* [fold f m accu] folds over all vertices. *)
  65
  66   val fold: (Vertex.t -> Register.Set.t -> 'a -> 'a) -> t -> 'a -> 'a
  67
  68   (* [coalesce x y m] coalesces vertices [x] and [y]. Vertex [x] is
  69      removed and the pseudo-registers associated with it become
  70      associated with [y] instead. *)
  71
  72   val coalesce: Vertex.t -> Vertex.t -> t -> t
  73
  74   (* [remove x m] removes vertex [x]. The pseudo-registers associated
  75      with [x] disappear. *)
  76
  77   val remove: Vertex.t -> t -> t
  78
  79   (* [restrict] keeps only those vertices that satisfy predicate [p]. *)
  80
  81   val restrict: (Vertex.t -> bool) -> t -> t
  82
  83 end = struct
  84
  85   type t = {
  86       forward: Register.Set.t Vertex.Map.t;
  87       backward: Vertex.t Register.Map.t
  88     }
  89
  90   let empty = {
  91     forward = Vertex.Map.empty;
  92     backward = Register.Map.empty
  93   }
  94
  95   let forward v m =
  96     Vertex.Map.find v m.forward
  97
  98   let backward r m =
  99     try
 100       Register.Map.find r m.backward
 101     with Not_found ->
 102       assert false (* bad pseudo-register *)
 103
 104   let add r v m = {
 105     forward = Vertex.Map.add v (Register.Set.singleton r) m.forward;
 106     backward = Register.Map.add r v m.backward
 107   }
 108
 109   let fold f m accu =
 110     Vertex.Map.fold f m.forward accu
 111
 112   let coalesce x y m =
 113     let rx, forward = Vertex.Map.find_remove x m.forward in
 114     let forward = Vertex.Map.update y (Register.Set.union rx) forward in
 115     let backward =
 116       Register.Set.fold (fun r backward ->
 117         Register.Map.add r y backward
 118       ) rx m.backward
 119     in
 120     {
 121       forward = forward;
 122       backward = backward
 123     }
 124
 125   let remove x m =
 126     let rx, forward = Vertex.Map.find_remove x m.forward in
 127     let backward = Register.Set.fold Register.Map.remove rx m.backward in
 128     {
 129       forward = forward;
 130       backward = backward
 131     }
 132
 133   let restrict p m = {
 134     forward = Vertex.Map.restrict p m.forward;
 135     backward = Register.Map.restrict (fun r -> p (backward r m)) m.backward
 136   }
 137
 138 end
 139
 140 (* ------------------------------------------------------------------------- *)
 141
 142 (* Graphs. *)
 143
 144 type graph = {
 145
 146     (* A two-way correspondence between vertices and pseudo-registers.
 147        This data structure is also used to keep a record of the set of
 148        all vertices. *)
 149
 150     regmap: RegMap.t;
 151
 152     (* Interference edges between two vertices: ``these two vertices
 153        cannot receive the same color''. *)
 154
 155     ivv: VertexSetMap.t;
 156
 157     (* Interference edges between a vertex and a hardware register:
 158        ``this vertex cannot receive this color''. *)
 159
 160     ivh: I8051RegisterSetMap.t;
 161
 162     (* Preference edges between two vertices: ``these two vertices
 163        should preferably receive the same color''. *)
 164
 165     pvv: VertexSetMap.t;
 166
 167     (* Preference edges between a vertex and a hardware register:
 168        ``this vertex should preferably receive this color''. *)
 169
 170     pvh: I8051RegisterSetMap.t;
 171
 172     (* The degree of each vertex [v], that is, the number of vertices
 173        and hardware registers that [v] interferes with, is recorded at
 174        all times. We use a ``priority set'' so as to be able to
 175        efficiently find a vertex of minimum degree. *)
 176
 177     degree: PrioritySet.t;
 178
 179     (* The degree of each *non-move-related* vertex [v]. This
 180         information is partially redundant with the [degree] field
 181         above. It is nevertheless required in order to be able to
 182         efficiently find a *non-move-related* vertex of minimum
 183         degree. *)
 184
 185     nmr: PrioritySet.t;
 186
 187   }
 188
 189 (* ------------------------------------------------------------------------- *)
 190
 191 (* Our graphs are made up of two subgraphs: the subgraph formed by the
 192    interference edges alone and the one formed by the preference edges
 193    alone.
 194
 195    In order to allow more code sharing, we define functions that allow
 196    dealing with a single subgraph at a time. They provide operations
 197    such as inspecting the neighbors of a vertex, adding edges,
 198    removing edges, coalescing two vertices, removing a vertex, etc.
 199
 200    We first define functions that deal with a ``generic'' subgraph,
 201    then (via inheritance) specialize them to deal with the
 202    interference subgraph and the preference subgraph with their
 203    specific features. *)
 204
 205 class virtual subgraph = object (self)
 206
 207   (* These methods provide access to the fields of the [graph] data
 208      structure that define the subgraph of interest. All data is
 209      stored in the [graph] data structure. The object [self] has no
 210      state and holds no data. *)
 211
 212   method virtual getvv: graph -> VertexSetMap.t
 213   method virtual setvv: graph -> VertexSetMap.t -> graph
 214   method virtual getvh: graph -> I8051RegisterSetMap.t
 215   method virtual setvh: graph -> I8051RegisterSetMap.t -> graph
 216
 217   (* Accessing the neighbors of a vertex and testing whether edges
 218      exist. *)
 219
 220   method neighborsv graph v =
 221     VertexSetMap.find v (self#getvv graph)
 222
 223   method existsvv graph v1 v2 =
 224     Vertex.Set.mem v1 (self#neighborsv graph v2)
 225
 226   method neighborsh graph v =
 227     I8051RegisterSetMap.find v (self#getvh graph)
 228
 229   method existsvh graph v h =
 230     I8051.RegisterSet.mem h (self#neighborsh graph v)
 231
 232   (* [degree graph v] is the degree of vertex [v] with respect to the
 233      subgraph. *)
 234
 235   method degree graph v =
 236     Vertex.Set.cardinal (self#neighborsv graph v) + I8051.RegisterSet.cardinal (self#neighborsh graph v)
 237
 238   (* [hwregs graph] is the set of all hardware registers mentioned in
 239      the subgraph. *)
 240
 241   method hwregs graph =
 242    let union _ = I8051.RegisterSet.union in
 243    Vertex.Map.fold union (self#getvh graph) I8051.RegisterSet.empty
 244
 245   (* [iter graph fvv fvh] iterates over all edges in the subgraph.
 246      Vertex-to-vertex edges are presented only once. *)
 247
 248   method iter graph fvv fvh =
 249     Vertex.Map.iter (fun vertex neighbors ->
 250       Vertex.Set.iter (fun neighbor ->
 251         if vertex < neighbor then
 252           fvv vertex neighbor
 253       ) neighbors
 254     ) (self#getvv graph);
 255     Vertex.Map.iter (fun vertex neighbors ->
 256       I8051.RegisterSet.iter (fun neighbor ->
 257         fvh vertex neighbor
 258       ) neighbors
 259     ) (self#getvh graph)
 260
 261   (* [mkvv graph v1 v2] adds an edge between vertices [v1] and [v2]. *)
 262
 263   method mkvv graph v1 v2 =
 264    if v1 = v2 then
 265      graph (* avoid creating self-edge *)
 266    else if self#existsvv graph v1 v2 then
 267      graph (* avoid re-adding an existing edge *)
 268    else
 269      self#mkvvi graph v1 v2
 270
 271   method mkvvi graph v1 v2 =
 272      self#setvv graph (VertexSetMap.mkbiedge v1 v2 (self#getvv graph))
 273
 274   (* [rmvv graph v1 v2] removes an edge between vertices [v1] and [v2].
 275      [rmvvifx] removes an edge if it exists. *)
 276
 277   method rmvv graph v1 v2 =
 278     assert (self#existsvv graph v1 v2);
 279     self#setvv graph (VertexSetMap.rmbiedge v1 v2 (self#getvv graph))
 280
 281   method rmvvifx graph v1 v2 =
 282     if self#existsvv graph v1 v2 then
 283       self#rmvv graph v1 v2
 284     else
 285       graph
 286
 287   (* [mkvh graph v h] adds an edge between vertex [v] and hardware
 288      register [h]. *)
 289
 290   method mkvh graph v h =
 291     if self#existsvh graph v h then
 292       graph (* avoid re-adding an existing edge *)
 293     else
 294       self#mkvhi graph v h
 295
 296   method mkvhi graph v h =
 297      self#setvh graph (I8051RegisterSetMap.update v (I8051.RegisterSet.add h) (self#getvh graph))
 298
 299   (* [rmvh v h] removes an edge between vertex [v] and hardware
 300      register [h]. [rmvhifx] removes an edge if it exists. *)
 301
 302   method rmvh graph v h =
 303     assert (self#existsvh graph v h);
 304     self#setvh graph (I8051RegisterSetMap.update v (I8051.RegisterSet.remove h) (self#getvh graph))
 305
 306   method rmvhifx graph v h =
 307     if self#existsvh graph v h then
 308       self#rmvh graph v h
 309     else
 310       graph
 311
 312   (* [coalesce graph x y] turns every neighbor [w] or [h] of [x] into
 313       a neighbor of [y] instead. [w] ranges over both vertices and
 314       hardware registers. *)
 315
 316   method coalesce graph x y =
 317     let graph =
 318       Vertex.Set.fold (fun w graph ->
 319         self#mkvv (self#rmvv graph x w) y w
 320       ) (self#neighborsv graph x) graph
 321     in
 322     let graph =
 323       I8051.RegisterSet.fold (fun h graph ->
 324         self#mkvh (self#rmvh graph x h) y h
 325       ) (self#neighborsh graph x) graph
 326     in
 327     graph
 328
 329   (* [coalesceh graph x h] turns every neighbor [w] of [x] into a
 330       neighbor of [h] instead. [w] ranges over both vertices and
 331       hardware registers. Edges between two hardware registers are not
 332       recorded. *)
 333
 334   method coalesceh graph x h =
 335     let graph =
 336       Vertex.Set.fold (fun w graph ->
 337         self#mkvh (self#rmvv graph x w) w h
 338       ) (self#neighborsv graph x) graph
 339     in
 340     let graph =
 341       I8051.RegisterSet.fold (fun k graph ->
 342         self#rmvh graph x k
 343       ) (self#neighborsh graph x) graph
 344     in
 345     graph
 346
 347   (* [remove graph x] removes all edges carried by vertex [x]. *)
 348
 349   method remove graph x =
 350     let graph =
 351       Vertex.Set.fold (fun w graph ->
 352         self#rmvv graph x w
 353       ) (self#neighborsv graph x) graph
 354     in
 355     let graph =
 356       I8051.RegisterSet.fold (fun h graph ->
 357         self#rmvh graph x h
 358       ) (self#neighborsh graph x) graph
 359     in
 360     graph
 361
 362 end
 363
 364 (* ------------------------------------------------------------------------- *)
 365
 366 (* The interference subgraph.
 367
 368    This is a subgraph with the following specific features: (1) the
 369    degree of every vertex is recorded in the [degree] field of the
 370    [graph] data structure; (2) the degree of every non-move-related
 371    vertex is recorded in the [nmr] field of the [graph] data
 372    structure; (3) creating an edge in the interference subgraph
 373    automatically destroys a corresponding edge in the preference
 374    subgraph. *)
 375
 376 class interference (preference : preference Lazy.t) = object (self)
 377
 378   inherit subgraph as super
 379
 380   method getvv graph = graph.ivv
 381   method setvv graph m = { graph with ivv = m }
 382   method getvh graph = graph.ivh
 383   method setvh graph m = { graph with ivh = m }
 384
 385   (* Override the edge creation and destruction methods. *)
 386
 387   method mkvvi graph v1 v2 =
 388     let graph = super#mkvvi graph v1 v2 in
 389     let graph = (Lazy.force preference)#rmvvifx graph v1 v2 in (* do not constrain an existing preference edge *)
 390     { graph with
 391       degree = PrioritySet.increment v1 1 (PrioritySet.increment v2 1 graph.degree);
 392       nmr = PrioritySet.incrementifx v1 1 (PrioritySet.incrementifx v2 1 graph.nmr);
 393     }
 394
 395   method rmvv graph v1 v2 =
 396     let graph = super#rmvv graph v1 v2 in
 397     { graph with
 398       degree = PrioritySet.increment v1 (-1) (PrioritySet.increment v2 (-1) graph.degree);
 399       nmr = PrioritySet.incrementifx v1 (-1) (PrioritySet.incrementifx v2 (-1) graph.nmr);
 400     }
 401
 402   method mkvhi graph v h =
 403     let graph = super#mkvhi graph v h in
 404     let graph = (Lazy.force preference)#rmvhifx graph v h in (* do not constrain an existing preference edge *)
 405     { graph with
 406       degree = PrioritySet.increment v 1 graph.degree;
 407       nmr = PrioritySet.incrementifx v 1 graph.nmr;
 408     }
 409
 410   method rmvh graph v h =
 411     let graph = super#rmvh graph v h in
 412     { graph with
 413       degree = PrioritySet.increment v (-1) graph.degree;
 414       nmr = PrioritySet.incrementifx v (-1) graph.nmr;
 415     }
 416
 417 end
 418
 419 (* ------------------------------------------------------------------------- *)
 420
 421 (* The preference subgraph.
 422
 423    This is a subgraph with the following specific features: (1) an
 424    edge in the preference subgraph cannot be created if a
 425    corresponding edge exists in the interference subgraph; (2) adding
 426    an edge can make a vertex move-related, which requires taking that
 427    vertex out of the [nmr] set; conversely, removing an edge can make
 428    a vertex non-move-related, which requires adding that vertex to the
 429    [nmr] set. *)
 430
 431 and preference (interference : interference Lazy.t) = object (self)
 432
 433   inherit subgraph as super
 434
 435   method getvv graph = graph.pvv
 436   method setvv graph m = { graph with pvv = m }
 437   method getvh graph = graph.pvh
 438   method setvh graph m = { graph with pvh = m }
 439
 440   (* [nmr graph v] tells whether vertex [v] is non-move-related. *)
 441
 442   method nmr graph v =
 443     Vertex.Set.is_empty (self#neighborsv graph v) &&
 444     I8051.RegisterSet.is_empty (self#neighborsh graph v)
 445
 446   (* [mkcheck graph v] moves [v] out of the [nmr] set if [v] is
 447      non-move-related. *)
 448
 449   method mkcheck graph v =
 450    if self#nmr graph v then
 451      { graph with
 452        nmr = PrioritySet.remove v graph.nmr }
 453    else
 454      graph
 455
 456   (* Override the edge creation methods. *)
 457
 458   method mkvvi graph v1 v2 =
 459     if (Lazy.force interference)#existsvv graph v1 v2 then
 460       graph (* avoid creating constrained preference edge *)
 461     else
 462       let graph = self#mkcheck graph v1 in
 463       let graph = self#mkcheck graph v2 in
 464       super#mkvvi graph v1 v2
 465
 466   method mkvhi graph v h =
 467     if (Lazy.force interference)#existsvh graph v h then
 468       graph (* avoid creating constrained preference edge *)
 469     else
 470       let graph = self#mkcheck graph v in
 471       super#mkvhi graph v h
 472
 473   (* [rmcheck graph v] moves [v] into the [nmr] set if [v] is
 474      non-move-related. *)
 475
 476   method rmcheck graph v =
 477     if self#nmr graph v then
 478       { graph with
 479         nmr = PrioritySet.add v (PrioritySet.priority v graph.degree) graph.nmr
 480       }
 481     else
 482       graph
 483
 484   (* Override the edge destruction methods. *)
 485
 486   method rmvv graph v1 v2 =
 487     let graph = super#rmvv graph v1 v2 in
 488     let graph = self#rmcheck graph v1 in
 489     let graph = self#rmcheck graph v2 in
 490     graph
 491
 492   method rmvh graph v h =
 493     let graph = super#rmvh graph v h in
 494     let graph = self#rmcheck graph v in
 495     graph
 496
 497 end
 498
 499 (* ------------------------------------------------------------------------- *)
 500
 501 (* Because the interference and preference subgraphs are mutually
 502    referential, a recursive definition is required. It is made
 503    somewhat inelegant by Objective Caml's insistence on using the
 504    [Lazy] mechanism. *)
 505
 506 let rec interference = lazy (new interference preference)
 507     and preference   = lazy (new preference interference)
 508 let interference     = Lazy.force interference
 509 let preference       = Lazy.force preference
 510
 511 (* ------------------------------------------------------------------------- *)
 512
 513 (* Inspecting interference graphs. *)
 514
 515 (* [ipp graph v] is the set of vertices that the vertex [v] interferes
 516    with. *)
 517
 518 let ipp graph v =
 519   interference#neighborsv graph v
 520
 521 (* [iph graph v] is the set of hardware registers that the vertex [v]
 522    interferes with. *)
 523
 524 let iph graph v =
 525   interference#neighborsh graph v
 526
 527 (* [ppp graph v] is the set of vertices that should preferably be
 528    assigned the same color as the vertex [v]. *)
 529
 530 let ppp graph v =
 531   preference#neighborsv graph v
 532
 533 (* [pph graph v] is the set of hardware registers that [v] should
 534    preferably be assigned. *)
 535
 536 let pph graph v =
 537   preference#neighborsh graph v
 538
 539 (* [degree graph v] is the degree of the vertex [v], that is, the number
 540    of vertices and hardware registers that [v] interferes with. *)
 541
 542 let degree graph v =
 543   PrioritySet.priority v graph.degree
 544
 545 (* [lowest graph] returns [Some (v, d)], where the vertex [v] has
 546    minimum degree [d], or returns [None] if the graph is empty. *)
 547
 548 let lowest graph =
 549   PrioritySet.lowest graph.degree
 550
 551 (* [lowest_non_move_related graph] returns [Some (v, d)], where the
 552    vertex [v] has minimum degree [d] among the vertices that are not
 553    move-related, or returns [None] if all vertices are move-related. A
 554    vertex is move-related if it carries a preference edge. *)
 555
 556 let lowest_non_move_related graph =
 557   PrioritySet.lowest graph.nmr
 558
 559 (* [fold f graph accu] folds over all vertices. *)
 560
 561 let fold f graph accu =
 562   RegMap.fold (fun v _ accu -> f v accu) graph.regmap accu
 563
 564 (* [minimum f graph] returns a vertex [v] such that the value of [f x]
 565    is minimal. The values returned by [f] are compared using Objective
 566    Caml's generic comparison operator [<]. If the graph is empty,
 567    [None] is returned. *)
 568
 569 let minimum f graph =
 570   match
 571     fold (fun w accu ->
 572       let dw = f w in
 573       match accu with
 574       | None ->
 575           Some (dw, w)
 576       | Some (dv, v) ->
 577           if dw < dv then
 578             Some (dw, w)
 579           else
 580             accu
 581     ) graph None
 582   with
 583   | None ->
 584       None
 585   | Some (_, v) ->
 586       Some v
 587
 588 (* [pppick graph p] returns an arbitrary preference edge that
 589    satisfies the predicate [p], if the graph contains one. *)
 590
 591 type ppedge =
 592     Vertex.t * Vertex.t
 593
 594 let pppick graph p =
 595   VertexSetMap.pick graph.pvv p
 596
 597 (* [phpick graph p] returns an arbitrary preference edge that
 598    satisfies the predicate [p], if the graph contains one. *)
 599
 600 type phedge =
 601     Vertex.t * I8051.register
 602
 603 let phpick graph p =
 604   I8051RegisterSetMap.pick graph.pvh p
 605
 606 (* ------------------------------------------------------------------------- *)
 607
 608 (* Constructing interference graphs. *)
 609
 610 (* [create regs] creates an interference graph whose vertices are
 611    the pseudo-registers [regs] and that does not have any edges. *)
 612
 613 let create regs =
 614   let (_ : int), regmap, degree =
 615     Register.Set.fold (fun r (v, regmap, degree) ->
 616       v+1,
 617       RegMap.add r v regmap,
 618       PrioritySet.add v 0 degree
 619     ) regs (0, RegMap.empty, PrioritySet.empty)
 620   in
 621   {
 622     regmap = regmap;
 623     ivv = Vertex.Map.empty;
 624     ivh = Vertex.Map.empty;
 625     pvv = Vertex.Map.empty;
 626     pvh = Vertex.Map.empty;
 627     degree = degree;
 628     nmr = degree
 629   }
 630
 631 (* [lookup graph r] returns the graph vertex associated with
 632    pseudo-register [r]. *)
 633
 634 let lookup graph r =
 635   RegMap.backward r graph.regmap
 636
 637 (* Conversely, [registers graph v] returns the set of pseudo-registers
 638    associated with vertex [v]. *)
 639
 640 let registers graph v =
 641   RegMap.forward v graph.regmap
 642
 643 (* [mkipp graph regs1 regs2] adds interference edges between all pairs
 644    of pseudo-registers [r1] and [r2], where [r1] ranges over [regs1],
 645    [r2] ranges over [regs2], and [r1] and [r2] are distinct. *)
 646
 647 let mkipp graph regs1 regs2 =
 648   Register.Set.fold (fun r1 graph ->
 649     let v1 = lookup graph r1 in
 650     Register.Set.fold (fun r2 graph ->
 651       interference#mkvv graph v1 (lookup graph r2)
 652     ) regs2 graph
 653   ) regs1 graph
 654
 655 (* [mkiph graph regs hwregs] adds interference edges between all pairs
 656    of a pseudo-register [r] and a hardware register [hwr], where [r]
 657    ranges over [regs] and [hwr] ranges over [hwregs]. *)
 658
 659 let mkiph graph regs hwregs =
 660   Register.Set.fold (fun r graph ->
 661     let v = lookup graph r in
 662     I8051.RegisterSet.fold (fun h graph ->
 663       interference#mkvh graph v h
 664     ) hwregs graph
 665   ) regs graph
 666
 667 (* [mki graph regs1 regs2] adds interference edges between all pairs
 668    of (pseudo- or hardware) registers [r1] and [r2], where [r1] ranges
 669    over [regs1], [r2] ranges over [regs2], and [r1] and [r2] are
 670    distinct. *)
 671
 672 let mki graph (regs1, hwregs1) (regs2, hwregs2) =
 673   let graph = mkipp graph regs1 regs2 in
 674   let graph = mkiph graph regs1 hwregs2 in
 675   let graph = mkiph graph regs2 hwregs1 in
 676   graph
 677
 678 (* [mkppp graph r1 r2] adds a preference edge between the
 679     pseudo-registers [r1] and [r2]. *)
 680
 681 let mkppp graph r1 r2 =
 682   let v1 = lookup graph r1
 683   and v2 = lookup graph r2 in
 684   let graph = preference#mkvv graph v1 v2 in
 685   graph
 686
 687 (* [mkpph graph r h] adds a preference edge between the
 688     pseudo-register [r] and the hardware register [h]. *)
 689
 690 let mkpph graph r h =
 691   let v = lookup graph r in
 692   let graph = preference#mkvh graph v h in
 693   graph
 694
 695 (* ------------------------------------------------------------------------- *)
 696
 697 (* Displaying interference graphs. *)
 698
 699 open Printf
 700
 701 let hwregs graph =
 702   I8051.RegisterSet.union (interference#hwregs graph) (preference#hwregs graph)
 703
 704 let print_vertex graph v =
 705   Register.Set.print (registers graph v)
 706
 707 let print f graph =
 708
 709   fprintf f "graph G {\n";
 710 (*  fprintf f "size=\"6, 3\";\n"; (* in inches *)*)
 711   fprintf f "orientation = landscape;\n";
 712   fprintf f "rankdir = LR;\n";
 713   fprintf f "ratio = compress;\n\n"; (* compress or fill or auto *)
 714
 715   RegMap.fold (fun vertex regs () ->
 716     fprintf f "r%d [ label=\"%s\" ] ;\n" vertex (Register.Set.print regs)
 717   ) graph.regmap ();
 718
 719   I8051.RegisterSet.iter (fun hwr ->
 720     let name = I8051.print_register hwr in
 721     fprintf f "hwr%s [ label=\"$%s\" ] ;\n" name name
 722   ) (hwregs graph);
 723
 724   interference#iter graph
 725     (fun vertex neighbor ->
 726       fprintf f "r%d -- r%d ;\n" vertex neighbor)
 727     (fun vertex neighbor ->
 728       fprintf f "r%d -- hwr%s ;\n" vertex (I8051.print_register neighbor));
 729
 730   preference#iter graph
 731     (fun vertex neighbor ->
 732       fprintf f "r%d -- r%d [ style = dashed ] ;\n" vertex neighbor)
 733     (fun vertex neighbor ->
 734       fprintf f "r%d -- hwr%s [ style = dashed ] ;\n" vertex (I8051.print_register neighbor));
 735
 736   fprintf f "\n}\n"
 737
 738 (* ------------------------------------------------------------------------- *)
 739
 740 (* Coalescing. *)
 741
 742 (* [coalesce graph v1 v2] is a new graph where the vertices [v1] and [v2]
 743    are coalesced. The new coalesced vertex is known under the name [v2]. *)
 744
 745 let coalesce graph x y =
 746
 747   assert (x <> y); (* attempt to coalesce one vertex with itself *)
 748   assert (not (interference#existsvv graph x y)); (* attempt to coalesce two interfering vertices *)
 749
 750   (* Perform coalescing in the two subgraphs. *)
 751
 752   let graph = interference#coalesce graph x y in
 753   let graph = preference#coalesce graph x y in
 754
 755   (* Remove [x] from all tables. *)
 756
 757   {
 758     graph with
 759     regmap = RegMap.coalesce x y graph.regmap;
 760     ivh = Vertex.Map.remove x graph.ivh;
 761     pvh = Vertex.Map.remove x graph.pvh;
 762     degree = PrioritySet.remove x graph.degree;
 763     nmr = PrioritySet.remove x graph.nmr;
 764   }
 765
 766 (* [coalesceh graph v h] coalesces the vertex [v] with the hardware register
 767    [h]. This produces a new graph where [v] no longer exists and all edges
 768    leading to [v] are replaced with edges leading to [h]. *)
 769
 770 let coalesceh graph x h =
 771
 772   assert (not (interference#existsvh graph x h)); (* attempt to coalesce interfering entities *)
 773
 774   (* Perform coalescing in the two subgraphs. *)
 775
 776   let graph = interference#coalesceh graph x h in
 777   let graph = preference#coalesceh graph x h in
 778
 779   (* Remove [x] from all tables. *)
 780
 781   {
 782     graph with
 783     regmap = RegMap.remove x graph.regmap;
 784     ivh = Vertex.Map.remove x graph.ivh;
 785     pvh = Vertex.Map.remove x graph.pvh;
 786     degree = PrioritySet.remove x graph.degree;
 787     nmr = PrioritySet.remove x graph.nmr;
 788   }
 789
 790 (* ------------------------------------------------------------------------- *)
 791
 792 (* [freeze graph x] is a new graph where all preference edges carried
 793    by [x] are removed. *)
 794
 795 let freeze graph x =
 796   preference#remove graph x
 797
 798 (* ------------------------------------------------------------------------- *)
 799
 800 (* Removal. *)
 801
 802 (* [remove graph v] is a new graph where vertex [v] is removed. *)
 803
 804 let remove graph v =
 805
 806   (* Remove all edges carried by [v]. *)
 807
 808   let graph = interference#remove graph v in
 809   let graph = preference#remove graph v in
 810
 811   (* Remove [v] from all tables. *)
 812
 813   {
 814     graph with
 815     regmap = RegMap.remove v graph.regmap;
 816     degree = PrioritySet.remove v graph.degree;
 817     nmr = PrioritySet.remove v graph.nmr;
 818   }
 819
 820 (* ------------------------------------------------------------------------- *)
 821
 822 (* [mkdeg graph] recomputes degree information from scratch. *)
 823
 824 let mkdeg graph =
 825   let degree, nmr =
 826     fold (fun v (degree, nmr) ->
 827       let d = interference#degree graph v in
 828       PrioritySet.add v d degree,
 829       if preference#nmr graph v then PrioritySet.add v d nmr else nmr
 830       ) graph (PrioritySet.empty, PrioritySet.empty)
 831   in
 832   { graph with
 833     degree = degree;
 834     nmr = nmr;
 835   }
 836
 837 (* [restrict graph p] is a new graph where only those vertices that
 838    satisfy predicate [p] are kept. The same effect could be obtained
 839    by repeated application of [remove], but [restrict] is likely to be
 840    more efficient if many vertices are removed. *)
 841
 842 let restrict graph p =
 843   mkdeg {
 844     graph with
 845     regmap = RegMap.restrict p graph.regmap;
 846     ivv = VertexSetMap.restrict p graph.ivv;
 847     ivh = Vertex.Map.restrict p graph.ivh;
 848     pvv = VertexSetMap.restrict p graph.pvv;
 849     pvh = Vertex.Map.restrict p graph.pvh;
 850   }
 851
 852 (* [droph graph] is a new graph where all information concerning hardware
 853    registers has been dropped. *)
 854
 855 let droph graph =
 856   mkdeg {
 857     graph with
 858     ivh = Vertex.Map.empty;
 859     pvh = Vertex.Map.empty;
 860   }
 861