End BBLOCK_SOLVER.
(** The implementation of the ``extended basic block'' solver is a functor parameterized by any ordered type with a top element. *)
Module BBlock_solver(LAT: ORDERED_TYPE_WITH_TOP):
BBLOCK_SOLVER with Module L := LAT.
Module L := LAT.
Section Solver.
Context {A: Type}.
Variable code: PTree.t A.
Variable successors: A -> list positive.
Variable transf: positive -> L.t -> L.t.
Variable entrypoint: positive.
Variable P: L.t -> Prop.
Hypothesis Ptop: P L.top.
Hypothesis Ptransf: forall pc instr x, code!pc = Some instr -> P x -> P (transf pc x).
Definition bbmap := positive -> bool.
Definition result := PMap.t L.t.
(** As in Kildall's solver, the state of the iteration has two components: - A mapping from program points to values of type [L.t] representing the candidate solution found so far. - A worklist of program points that remain to be considered. *)
Record state : Type := mkstate
{ aval: result; worklist: list positive }.
(** The ``extended basic block'' algorithm, in pseudo-code, is as follows: << worklist := the set of all points n having multiple predecessors aval  := the mapping n -> L.top  while worklist is not empty, do extract a node n from worklist compute out = transf n aval[n] for each successor s of n: if s has only one predecessor (namely, n): aval[s] := out worklist := worklist union {s} end if end for end while return aval >> **)
Fixpoint propagate_successors
(bb: bbmap) (succs: list positive) (l: L.t) (st: state)
{struct succs} : state :=
match succs with
| nil => st
| s1 :: sl =>
if bb s1 then
propagate_successors bb sl l st
else
propagate_successors bb sl l
(mkstate (PMap.set s1 l st.(aval))
(s1 :: st.(worklist)))
end.
Definition step (bb: bbmap) (st: state) : result + state :=
match st.(worklist) with
| nil => inl _ st.(aval)
| pc :: rem =>
match code!pc with
| None =>
inr _ (mkstate st.(aval) rem)
| Some instr =>
inr _ (propagate_successors
bb (successors instr)
(transf pc st.(aval)!!pc)
(mkstate st.(aval) rem))
end
end.
(** Recognition of program points that have more than one predecessor. *)
Definition is_basic_block_head
(preds: PTree.t (list positive)) (pc: positive) : bool :=
if peq pc entrypoint then true else
match preds!!!pc with
| nil => false
| s :: nil => peq s pc
| _ :: _ :: _ => true
end.
Definition basic_block_map : bbmap :=
is_basic_block_head (make_predecessors code successors).
Definition basic_block_list (bb: bbmap) : list positive :=
PTree.fold (fun l pc instr => if bb pc then pc :: l else l)
code nil.
(** The computation of the approximate solution. *)
Definition fixpoint : option result :=
let bb := basic_block_map in
PrimIter.iterate _ _ (step bb) (mkstate (PMap.init L.top) (basic_block_list bb)).
(** ** Properties of predecessors and multiple-predecessors nodes *)
Definition predecessors := make_predecessors code successors.

(* Specifications: *)
Lemma predecessors_correct:
forall n instr s,
code!n = Some instr -> In s (successors instr) -> In n predecessors!!!s.
Lemma multiple_predecessors:
forall s n1 instr1 n2 instr2,
code!n1 = Some instr1 -> In s (successors instr1) ->
code!n2 = Some instr2 -> In s (successors instr2) ->
n1 <> n2 ->
basic_block_map s = true.
Lemma no_self_loop:
forall n instr,
code!n = Some instr -> In n (successors instr) -> basic_block_map n = true.