Require Import VST.floyd.base2.
Import ListNotations.

Module PosOrder <: Orders.TotalLeBool.
  Definition t := positive.
  Definition leb := Pos.leb.
  Theorem leb_total : forall a1 a2, Pos.leb a1 a2 = true \/ Pos.leb a2 a1 = true.
  Proof.  intros.
    pose proof (Pos.leb_spec a1 a2).
    pose proof (Pos.leb_spec a2 a1).
    inv H; inv H0; auto.
    clear - H2 H3.
    pose proof (Pos.lt_trans _ _ _ H2 H3).
    apply Pos.lt_irrefl in H. contradiction.
  Qed.
End PosOrder.
Module SortPos := Mergesort.Sort(PosOrder).

Module CompOrder <: Orders.TotalLeBool.
  Definition t := composite_definition.
  Definition leb := fun x y => Pos.leb (name_composite_def x) (name_composite_def y).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.  intros. unfold leb.
    pose proof (Pos.leb_spec (name_composite_def a1) (name_composite_def a2)).
    pose proof (Pos.leb_spec (name_composite_def a2) (name_composite_def a1)).
    inv H; inv H0; auto.
    clear - H2 H3.
    pose proof (Pos.lt_trans _ _ _ H2 H3).
    apply Pos.lt_irrefl in H. contradiction.
  Qed.
End CompOrder.
Module SortComp := Mergesort.Sort(CompOrder).

Module GlobdefOrder <: Orders.TotalLeBool.
  Definition t := (ident * globdef (fundef function) type)%type.
  Definition leb := fun x y : (ident * globdef (fundef function) type)=> Pos.leb (fst x) (fst y).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.  intros. unfold leb.
    pose proof (Pos.leb_spec (fst a1) (fst a2)).
    pose proof (Pos.leb_spec (fst a2) (fst a1)).
    inv H; inv H0; auto.
    clear - H2 H3.
    pose proof (Pos.lt_trans _ _ _ H2 H3).
    apply Pos.lt_irrefl in H. contradiction.
  Qed.
End GlobdefOrder.
Module SortGlobdef := Mergesort.Sort(GlobdefOrder).

Definition isnil {A} (al: list A) :=
   match al with nil => true | _ => false end.

Lemma prod_eq_dec {A B} (Ha: forall (a1 a2:A), {a1 = a2} + {a1<>a2})
      (Hb: forall (b1 b2:B), {b1 = b2} + {b1<>b2}):
      forall (x y : A * B), {x=y} + {x<>y}.
Proof. intros. destruct x as [a1 b1]. destruct y as [a2 b2].
destruct (Ha a1 a2); [ subst | right; congruence].
destruct (Hb b1 b2); [ subst; left; trivial | right; congruence].
Defined.

Lemma function_eq_dec (f g: function): { f=g } + { f <> g }.
Proof.
destruct f as [rtF ccF paramsF varsF tempsF bodyF].
destruct g as [rtG ccG paramsG varsG tempsG bodyG].
destruct (type_eq rtF rtG); [ subst | right; congruence].
destruct (calling_convention_eq ccF ccG); [ subst | right; congruence].
destruct (list_eq_dec (prod_eq_dec ident_eq type_eq) paramsF paramsG); [ subst | right; congruence].
destruct (list_eq_dec (prod_eq_dec ident_eq type_eq) varsF varsG); [ subst | right; congruence].
destruct (list_eq_dec (prod_eq_dec ident_eq type_eq) tempsF tempsG); [ subst | right; congruence].
destruct (semax_lemmas.eq_dec_statement bodyF bodyG); [ subst; left; trivial | right; congruence].
Defined.

Definition merge_globdef (g1 g2: globdef (fundef function) type) :=
 match g1, g2 with
 | Gfun (External _ _ _ _), Gfun (External _ _ _ _) =>
     Errors.OK g1  (* SHOULD CHECK g1=g2 *)
 | Gfun (External _ _ _ _), Gfun (Internal f2) =>
     Errors.OK g2  (* SHOULD CHECK TYPES MATCH *)
 | Gfun (Internal f1), Gfun (External _ _ _ _) =>
    Errors.OK g1  (* SHOULD CHECK TYPES MATCH *)
 | Gfun (Internal f), Gfun (Internal g) => Errors.OK g1 (*this is OK
      since VSU.ComponentJoin contains hypothesis Fundefs_match*)
    (*Errors.Error [Errors.MSG "internal function clash"]*)
   (* if function_eq_dec f g then Errors.OK g1
    else Errors.Error [Errors.MSG "internal function clash"]*)
 | Gvar {| gvar_info := i1; gvar_init := l1; gvar_readonly := r1; gvar_volatile := v1 |},
   Gvar {| gvar_info := i2; gvar_init := l2; gvar_readonly := r2; gvar_volatile := v2 |} =>
   if (eqb_type i1 i2 &&
      bool_eq r1 r2 &&
      bool_eq v1 v2)%bool
   then if isnil l1
           then Errors.OK g2
           else if isnil l2 then Errors.OK g1
           else Errors.Error [Errors.MSG "Gvars both initialized"]
   else Errors.Error [Errors.MSG "Gvar type/readonly/volatile clash"]
  | _, _ => Errors.Error [Errors.MSG "Gvar versus Gfun"]
 end.

Function merge_global_definitions'
    (d1 d2: list (ident * globdef (fundef function) type))
    (fuel: nat) :=
 match fuel with
 | O => Errors.Error [Errors.MSG "out of fuel"]
 | S fuel' =>
  match d1, d2 with
  | nil, _ => Errors.OK d2
  | _, nil => Errors.OK d1
  | (i1,g1)::d1', (i2,g2)::d2' =>
     if Pos.ltb i1 i2
     then match merge_global_definitions' d1' d2 fuel' with
            | Errors.OK dl => Errors.OK ((i1,g1)::dl)
            | err => err
            end
     else if Pos.ltb i2 i1
     then match merge_global_definitions' d1 d2' fuel' with
            | Errors.OK dl => Errors.OK ((i2,g2)::dl)
            | err => err
            end
    else match merge_globdef g1 g2 with
           | Errors.OK g => match merge_global_definitions' d1' d2' fuel' with
                     | Errors.OK dl => Errors.OK ((i1,g)::dl)
                     | Errors.Error el => Errors.Error el
                    end
            | Errors.Error err => Errors.Error (Errors.POS i1 :: err)
            end
 end end.

Definition merge_global_definitions
    (d1 d2: list (ident * globdef (fundef function) type)) :=
 merge_global_definitions' d1 d2 (length d1 + length d2).

Fixpoint merge_prog_types' (e1 e2: list composite_definition)
                 (fuel: nat)
              : Errors.res (list composite_definition) :=
 match fuel with
 | O => Errors.Error [Errors.MSG "ran out of fuel in composites"]
 | S fuel' =>
 match e1, e2 with
 | nil, _ => Errors.OK e2
 | _, nil => Errors.OK e1
 | (Composite i1 su1 m1 a1 as c1) :: e1',
   (Composite i2 su2 m2 a2 as c2) :: e2' =>
   if Pos.ltb i1 i2
   then Errors.bind (merge_prog_types' e1' e2 fuel')
          (fun e => Errors.OK (c1::e))
   else if Pos.ltb i2 i1
   then Errors.bind (merge_prog_types' e1 e2' fuel')
          (fun e => Errors.OK (c2::e))
   else if (eqb_su su1 su2 &&
              eqb_list eqb_member m1 m2 &&
              eqb_attr a1 a2)%bool
   then Errors.bind (merge_prog_types' e1' e2' fuel')
          (fun e => Errors.OK (c1::e))
   else Errors.Error [Errors.MSG "struct/union does not match:"; Errors.POS i1]
 end
end.

Definition merge_prog_types e1 e2 :=
 merge_prog_types' e1 e2 (S(length e1 + length e2)).

Definition link_progs (prog1 prog2 : Clight.program) :
  Errors.res Clight.program :=
 match prog1, prog2 with
  {|prog_defs := d1;
    prog_public := p1;
    prog_main := m1;
    prog_types := t1;
    prog_comp_env := e1;
    prog_comp_env_eq := q1|},
  {|prog_defs := d2;
    prog_public := p2;
    prog_main := m2;
    prog_types := t2;
    prog_comp_env := e2;
    prog_comp_env_eq := q2|}  =>
 Errors.bind (merge_global_definitions
               (SortGlobdef.sort d1) (SortGlobdef.sort d2)) (fun d =>
 Errors.bind (merge_prog_types (SortComp.sort t1) (SortComp.sort t2)) (fun t =>
 match build_composite_env t as e
       return (build_composite_env t = e -> Errors.res Clight.program) with
 | Errors.Error err => fun _ => Errors.Error err
 | Errors.OK e =>  fun q =>
 if negb (eqb_ident m1 m2)
   then Errors.Error [Errors.MSG "main identifiers differ"]
   else
    Errors.OK {| prog_defs := d;
    prog_public := SortPos.merge (SortPos.sort p1) (SortPos.sort p2);
    prog_main := m2;
    prog_types := t;
    prog_comp_env := e;
    prog_comp_env_eq := q|}
   end eq_refl ))
end.

Definition link_progs_list (pl: list Clight.program) :
  Errors.res Clight.program :=
 match pl with
 | nil => Errors.Error [Errors.MSG "no programs to link"]
 | p::pl' => List.fold_left (fun q p =>
                  match q with
                  | Errors.Error e => q
                  | Errors.OK q' => link_progs q' p
                  end) pl' (Errors.OK p)
  end.

Ltac link_progs_list pl :=
 let q := constr:(linking.link_progs_list pl) in
 let q := eval hnf in q in
 let q := eval cbv beta iota delta [linking.SortComp.sort] in q in
 let q := eval simpl in q in
 match q with
 | Errors.Error ?e => fail 1 e
 | Errors.OK ?q' => exact q'
 end.

(*duplicate of lemma in globals_lemas*)
Lemma prog_defs_Clight_mkprogram:
 forall c g p m w,
 prog_defs (Clightdefs.mkprogram c g p m w) = g.
Proof.
intros. unfold Clightdefs.mkprogram.
destruct ( build_composite_env' c w).
reflexivity.
Qed.

Lemma prog_types_Clight_mkprogram:
  forall (c : list composite_definition) (g : list (ident * globdef Clight.fundef type)) (p : list ident)
    (m : ident) (w : wf_composites c), prog_types (Clightdefs.mkprogram c g p m w) = c.
Proof. intros. unfold prog_types. unfold Clightdefs.mkprogram.
destruct (build_composite_env' c w ); trivial.
Qed.

Module NEW_LINK_PROGS.  (* Everything in this Module should perhaps be moved to floyd/linking.v *)

(* All of this complexity is because the naturally computed proof whose type is
     build_composite_env t12 = Errors.OK e12
  blows up:  the nested environments explode exponentially.
 And that's a pity, because after all we have  proof irrelevance.  But I could not
 think of a better way than this to exploit proof irrelevance.  -- Andrew, 7/24/2020
*)
Definition carefully_link_progs (prog1 prog2 : Clight.program)
  (MAIN: prog_main prog1 = prog_main prog2)
  (d12: list (ident * globdef (fundef function) type))
  (Hd12: merge_global_definitions
               (SortGlobdef.sort (prog_defs prog1)) (SortGlobdef.sort (prog_defs prog2)) = Errors.OK d12)
  (t12: list composite_definition)
  (Ht12: merge_prog_types (SortComp.sort (prog_types prog1)) (SortComp.sort (prog_types prog2)) = Errors.OK t12)
  (e12: composite_env)
  (He12: build_composite_env t12 = Errors.OK e12)
  : Clight.program :=
 {| prog_defs := d12;
    prog_public := SortPos.merge (SortPos.sort (prog_public prog1)) (SortPos.sort (prog_public prog2));
    prog_main := prog_main prog2;
    prog_types := t12;
    prog_comp_env := e12;
    prog_comp_env_eq := He12|} .

Lemma Gt_neq_Lt: Gt = Lt -> False.
Proof. congruence. Qed.

Lemma prove_exists_align_attr:
  forall d, two_power_nat (Z.to_nat (Z.log2 d)) = d ->
    exists n, align_attr noattr d = two_power_nat n.
Proof.
intros.
exists (Z.to_nat (Z.log2 d)).
rewrite H. reflexivity.
Qed.

Lemma prove_align_attr:
  forall i j,  (j/i)*i=j -> (align_attr noattr i | j).
Proof. intros. exists (j/i). symmetry. apply H. Qed.

Ltac process_composite_definitions_step :=
repeat
match goal with
|- Errors.bind match ?z with _ => _ end  _  = _ =>
  set (j := z); hnf in j; simpl in j; subst j; cbv beta iota
end;
 match goal with |- context [Ctypes.composite_of_def_obligation_1 _ _ _ _] =>
   set (x := Ctypes.composite_of_def_obligation_1 _ _ _ _);
  simpl in x;
  match type of x with ?t =>
    replace x with (Gt_neq_Lt : t) by apply proof_irr
 end;
  clear x
end;
 match goal with |- context [Ctypes.composite_of_def_obligation_2 _ _ _] =>
   set (x := Ctypes.composite_of_def_obligation_2 _ _ _);
  simpl in x;
  match type of x with (exists i, align_attr noattr ?d = two_power_nat i) =>
    replace x with (prove_exists_align_attr d (eq_refl _)) by apply proof_irr
 end;
  clear x
end;
repeat
  match goal with |- context [Ctypes.composite_of_def_obligation_3 _ _ _ _] =>
   set (x := Ctypes.composite_of_def_obligation_3 _ _ _ _);
  simpl in x;
  match type of x with (align_attr noattr ?i | ?j)  =>
    replace x with (prove_align_attr i j (eq_refl _)) by apply proof_irr
 end;
  clear x
end;
change (Errors.bind (Errors.OK ?x) ?f) with (f x); cbv beta iota.

Ltac process_composite_definitions :=
 simpl;
 unfold build_composite_env;
 unfold add_composite_definitions, composite_of_def;
 simpl align; simpl align_attr; simpl rank_members;
 simpl PTree.set;
 repeat process_composite_definitions_step;
 reflexivity.

Ltac do_merge_global_definitions :=
match goal with |- context [SortGlobdef.sort ?x] =>
 set (j :=SortGlobdef.sort x); hnf in j; simpl in j; subst j
end;
match goal with |- context [SortGlobdef.sort ?x] =>
 set (j :=SortGlobdef.sort x); hnf in j; simpl in j; subst j
end;
match goal with |- ?A = _ =>
 set (j :=A); hnf in j; simpl in j; subst j
end; reflexivity.

Ltac do_merge_prog_types :=
match goal with |- context [SortComp.sort ?x] =>
 set (j :=SortComp.sort x); hnf in j; simpl in j; subst j
end;
match goal with |- context [SortComp.sort ?x] =>
 set (j :=SortComp.sort x); hnf in j; simpl in j; subst j
end;
match goal with |- ?A = _ =>
 set (j :=A); hnf in j; simpl in j; subst j
end; reflexivity.

Ltac do_link_progs_step1 p1 p2 :=
  eapply (carefully_link_progs p1 p2 (eq_refl _));
  [time "merge_global" do_merge_global_definitions
  |time "merge_types" do_merge_prog_types
  |time "process_composites" process_composite_definitions].

Ltac do_merge_global_definitions_unfold p1 p2 :=
  unfold p1; try rewrite prog_defs_Clight_mkprogram;
  unfold p2; try rewrite prog_defs_Clight_mkprogram;
  do_merge_global_definitions.

Ltac do_merge_prog_types_unfold p1 p2 :=
 unfold p1; try rewrite prog_types_Clight_mkprogram;
 unfold p2; try rewrite prog_types_Clight_mkprogram;
  do_merge_prog_types.

Ltac do_link_progs_step1_unfold p1 p2 :=
  eapply (carefully_link_progs p1 p2 (eq_refl _));
  [time "merge_global" do_merge_global_definitions_unfold p1 p2
  |time "merge_types" do_merge_prog_types_unfold p1 p2
  |time "process_composites" process_composite_definitions].

Ltac do_link_progs_step2 p :=
let x := eval hnf in p in
match x with
 {| prog_defs := ?d;
    prog_public := ?p;
    prog_main := ?m;
    prog_types := ?t;
    prog_comp_env := ?e;
    prog_comp_env_eq := _ |} =>
refine  {| prog_defs := d;
    prog_public := p;
    prog_main := m;
    prog_types := t;
    prog_comp_env := e;
    prog_comp_env_eq := _ |}
end;
abstract (exact (prog_comp_env_eq p)).

End NEW_LINK_PROGS.
(* Now, to use NEW_LINK_PROGS, it is unfortunately necessary to do this in two steps*)


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Constant propagation over RTL.  This is one of the optimizations
  performed at RTL level.  It proceeds by a standard dataflow analysis
  and the corresponding code rewriting. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Globalenvs.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import Lattice.
Require Import Kildall.
Require Import ConstpropOp.

(** * Static analysis *)

(** The type [approx] of compile-time approximations of values is
  defined in the machine-dependent part [ConstpropOp]. *)

(** We equip this type of approximations with a semi-lattice structure.
  The ordering is inclusion between the sets of values denoted by
  the approximations. *)

Module Approx <: SEMILATTICE_WITH_TOP.
  Definition t := approx.
  Definition eq (x y: t) := (x = y).
  Definition eq_refl: forall x, eq x x := (@refl_equal t).
  Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t).
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t).
  Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}.
  Proof.
    decide equality.
    apply Int.eq_dec.
    apply Float.eq_dec.
    apply Int.eq_dec.
    apply ident_eq.
    apply Int.eq_dec.
  Qed.
  Definition beq (x y: t) := if eq_dec x y then true else false.
  Lemma beq_correct: forall x y, beq x y = true -> x = y.
  Proof.
    unfold beq; intros.  destruct (eq_dec x y). auto. congruence.
  Qed.

  Definition ge (x y: t) : Prop := x = Unknown \/ y = Novalue \/ x = y.

  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge; tauto.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge; intuition congruence.
  Qed.
  Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'.
  Proof.
    unfold eq, ge; intros; congruence.
  Qed.
  Definition bot := Novalue.
  Definition top := Unknown.
  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot; tauto.
  Qed.
  Lemma ge_top: forall x, ge top x.
  Proof.
    unfold ge, bot; tauto.
  Qed.
  Definition lub (x y: t) : t :=
    if eq_dec x y then x else
    match x, y with
    | Novalue, _ => y
    | _, Novalue => x
    | _, _ => Unknown
    end.
  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold lub; intros.
    case (eq_dec x y); intro.
    apply ge_refl. apply eq_refl.
    destruct x; destruct y; unfold ge; tauto.
  Qed.
  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold lub; intros.
    case (eq_dec x y); intro.
    apply ge_refl. subst. apply eq_refl.
    destruct x; destruct y; unfold ge; tauto.
  Qed.
End Approx.

Module D := LPMap Approx.

(** We keep track of read-only global variables (i.e. "const" global
  variables in C) as a map from their names to their initialization
  data. *)

Definition global_approx : Type := PTree.t (list init_data).

(** Given some initialization data and a byte offset, compute a static
  approximation of the result of a memory load from a memory block
  initialized with this data. *)

Fixpoint eval_load_init (chunk: memory_chunk) (pos: Z) (il: list init_data): approx :=
  match il with
  | nil => Unknown
  | Init_int8 n :: il' =>
      if zeq pos 0 then
        match chunk with
        | Mint8unsigned => I (Int.zero_ext 8 n)
        | Mint8signed => I (Int.sign_ext 8 n)
        | _ => Unknown
        end
      else eval_load_init chunk (pos - 1) il'
  | Init_int16 n :: il' =>
      if zeq pos 0 then
        match chunk with
        | Mint16unsigned => I (Int.zero_ext 16 n)
        | Mint16signed => I (Int.sign_ext 16 n)
        | _ => Unknown
        end
      else eval_load_init chunk (pos - 2) il'
  | Init_int32 n :: il' =>
      if zeq pos 0
      then match chunk with Mint32 => I n | _ => Unknown end
      else eval_load_init chunk (pos - 4) il'
  | Init_float32 n :: il' =>
      if zeq pos 0
      then match chunk with
           | Mfloat32 => if propagate_float_constants tt then F (Float.singleoffloat n) else Unknown
           | _ => Unknown
           end
      else eval_load_init chunk (pos - 4) il'
  | Init_float64 n :: il' =>
      if zeq pos 0
      then match chunk with
           | Mfloat64 => if propagate_float_constants tt then F n else Unknown
           | _ => Unknown
           end
      else eval_load_init chunk (pos - 8) il'
  | Init_addrof symb ofs :: il' =>
      if zeq pos 0
      then match chunk with Mint32 => G symb ofs | _ => Unknown end
      else eval_load_init chunk (pos - 4) il'
  | Init_space n :: il' =>
      eval_load_init chunk (pos - Zmax n 0) il'
  end.

(** Compute a static approximation for the result of a load at an address whose
  approximation is known.  If the approximation points to a global variable,
  and this global variable is read-only, we use its initialization data
  to determine a static approximation.  Otherwise, [Unknown] is returned. *)

Definition eval_static_load (gapp: global_approx) (chunk: memory_chunk) (addr: approx) : approx :=
  match addr with
  | G symb ofs =>
      match gapp!symb with
      | None => Unknown
      | Some il => eval_load_init chunk (Int.unsigned ofs) il
      end
  | _ => Unknown
  end.

(** The transfer function for the dataflow analysis is straightforward.
  For [Iop] instructions, we set the approximation of the destination
  register to the result of executing abstractly the operation.
  For [Iload] instructions, we set the approximation of the destination
  register to the result of [eval_static_load].
  For [Icall] and [Ibuiltin], the destination register becomes [Unknown].
  Other instructions keep the approximations unchanged, as they preserve
  the values of all registers. *)

Definition approx_reg (app: D.t) (r: reg) :=
  D.get r app.

Definition approx_regs (app: D.t) (rl: list reg):=
  List.map (approx_reg app) rl.

Definition transfer (gapp: global_approx) (f: function) (pc: node) (before: D.t) :=
  match f.(fn_code)!pc with
  | None => before
  | Some i =>
      match i with
      | Iop op args res s =>
          let a := eval_static_operation op (approx_regs before args) in
          D.set res a before
      | Iload chunk addr args dst s =>
          let a := eval_static_load gapp chunk
                     (eval_static_addressing addr (approx_regs before args)) in
          D.set dst a before
      | Icall sig ros args res s =>
          D.set res Unknown before
      | Ibuiltin ef args res s =>
          D.set res Unknown before
      | _ =>
          before
      end
  end.

(** The static analysis itself is then an instantiation of Kildall's
  generic solver for forward dataflow inequations. [analyze f]
  returns a mapping from program points to mappings of pseudo-registers
  to approximations.  It can fail to reach a fixpoint in a reasonable
  number of iterations, in which case we use the trivial mapping
  (program point -> [D.top]) instead. *)

Module DS := Dataflow_Solver(D)(NodeSetForward).

Definition analyze (gapp: global_approx) (f: RTL.function): PMap.t D.t :=
  match DS.fixpoint (successors f) (transfer gapp f)
                    ((f.(fn_entrypoint), D.top) :: nil) with
  | None => PMap.init D.top
  | Some res => res
  end.

(** * Code transformation *)

(** The code transformation proceeds instruction by instruction.
    Operators whose arguments are all statically known are turned
    into ``load integer constant'', ``load float constant'' or
    ``load symbol address'' operations.  Likewise for loads whose
    result can be statically predicted.  Operators for which some
    but not all arguments are known are subject to strength reduction,
    and similarly for the addressing modes of load and store instructions.
    Conditional branches and multi-way branches are statically resolved
    into [Inop] instructions if possible. Other instructions are unchanged. *)

Definition transf_ros (app: D.t) (ros: reg + ident) : reg + ident :=
  match ros with
  | inl r =>
      match D.get r app with
      | G symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros
      | _ => ros
      end
  | inr s => ros
  end.

Parameter generate_float_constants : unit -> bool.

Definition const_for_result (a: approx) : option operation :=
  match a with
  | I n => Some(Ointconst n)
  | F n => if generate_float_constants tt then Some(Ofloatconst n) else None
  | G symb ofs => Some(Oaddrsymbol symb ofs)
  | S ofs => Some(Oaddrstack ofs)
  | _ => None
  end.

Definition transf_instr (gapp: global_approx) (app: D.t) (instr: instruction) :=
  match instr with
  | Iop op args res s =>
      let a := eval_static_operation op (approx_regs app args) in
      match const_for_result a with
      | Some cop =>
          Iop cop nil res s
      | None =>
          let (op', args') := op_strength_reduction op args (approx_regs app args) in
          Iop op' args' res s
      end
  | Iload chunk addr args dst s =>
      let a := eval_static_load gapp chunk
                  (eval_static_addressing addr (approx_regs app args)) in
      match const_for_result a with
      | Some cop =>
          Iop cop nil dst s
      | None =>
          let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in
          Iload chunk addr' args' dst s
      end
  | Istore chunk addr args src s =>
      let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in
      Istore chunk addr' args' src s
  | Icall sig ros args res s =>
      Icall sig (transf_ros app ros) args res s
  | Itailcall sig ros args =>
      Itailcall sig (transf_ros app ros) args
  | Ibuiltin ef args res s =>
      let (ef', args') := builtin_strength_reduction ef args (approx_regs app args) in
      Ibuiltin ef' args' res s
  | Icond cond args s1 s2 =>
      match eval_static_condition cond (approx_regs app args) with
      | Some b =>
          if b then Inop s1 else Inop s2
      | None =>
          let (cond', args') := cond_strength_reduction cond args (approx_regs app args) in
          Icond cond' args' s1 s2
      end
  | Ijumptable arg tbl =>
      match approx_reg app arg with
      | I n =>
          match list_nth_z tbl (Int.unsigned n) with
          | Some s => Inop s
          | None => instr
          end
      | _ => instr
      end
  | _ =>
      instr
  end.

Definition transf_code (gapp: global_approx) (app: PMap.t D.t) (instrs: code) : code :=
  PTree.map (fun pc instr => transf_instr gapp app!!pc instr) instrs.

Definition transf_function (gapp: global_approx) (f: function) : function :=
  let approxs := analyze gapp f in
  mkfunction
    f.(fn_sig)
    f.(fn_params)
    f.(fn_stacksize)
    (transf_code gapp approxs f.(fn_code))
    f.(fn_entrypoint).

Definition transf_fundef (gapp: global_approx) (fd: fundef) : fundef :=
  AST.transf_fundef (transf_function gapp) fd.

Fixpoint make_global_approx (gapp: global_approx) (vars: list (ident * globvar unit)) : global_approx :=
  match vars with
  | nil => gapp
  | (id, gv) :: vars' =>
      let gapp1 :=
        if gv.(gvar_readonly) && negb gv.(gvar_volatile)
        then PTree.set id gv.(gvar_init) gapp
        else PTree.remove id gapp in
      make_global_approx gapp1 vars'
  end.

Definition transf_program (p: program) : program :=
  let gapp := make_global_approx (PTree.empty _) p.(prog_vars) in
  transform_program (transf_fundef gapp) p.


Require Import floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Local Open Scope logic.

Definition Delta_final_if1 : tycontext.
simplify_Delta_from
 (initialized _n  (initialized _p
     (func_tycontext f_SHA256_Final Vprog Gtot))).
Defined.

Definition Body_final_if1 :=
  (Ssequence
              (Scall None
                (Evar _memset (Tfunction
                                (Tcons (tptr tvoid)
                                  (Tcons tint (Tcons tuint Tnil)))
                                (tptr tvoid) cc_default))
                ((Ebinop Oadd (Etempvar _p (tptr tuchar)) (Etempvar _n tuint)
                   (tptr tuchar)) :: (Econst_int (Int.repr 0) tint) ::
                 (Ebinop Osub
                   (Ebinop Omul (Econst_int (Int.repr 16) tint)
                     (Econst_int (Int.repr 4) tint) tint) (Etempvar _n tuint)
                   tuint) :: nil))
              (Ssequence
                (Sset _n (Econst_int (Int.repr 0) tint))
                (Scall None
                  (Evar _sha256_block_data_order (Tfunction
                                                   (Tcons
                                                     (tptr t_struct_SHA256state_st)
                                                     (Tcons (tptr tvoid)
                                                       Tnil)) tvoid cc_default))
                  ((Etempvar _c (tptr t_struct_SHA256state_st)) ::
                   (Etempvar _p (tptr tuchar)) :: nil)))).

Definition invariant_after_if1 hashed (dd: list Z) c md shmd  hi lo kv:=
   (EX hashed':list int, EX dd': list Z, EX pad:Z,
   PROP  (Forall isbyteZ dd';
              pad=0%Z \/ dd'=nil;
              (length dd' + 8 <= CBLOCK)%nat;
              (0 <= pad < 8)%Z;
              (LBLOCKz | Zlength hashed')%Z;
              intlist_to_Zlist hashed' ++ dd' =
              intlist_to_Zlist hashed ++  dd
                  ++ [128%Z] ++ list_repeat (Z.to_nat pad) 0)
   LOCAL
   (`(eq (Vint (Int.repr (Zlength dd')))) (eval_id _n);
   `eq (eval_id _p)
     (`(offset_val (Int.repr 40)) (`force_ptr (eval_id _c)));
   `(eq md) (eval_id _md); `(eq c) (eval_id _c);
                     `(eq kv) (eval_var _K256 (tarray tuint CBLOCKz)))
   SEP  (`(array_at tuint Tsh (ZnthV tuint (map Vint (hash_blocks init_registers hashed'))) 0 8 c);
   `(field_at Tsh t_struct_SHA256state_st [_Nl] (Vint lo) c);
   `(field_at Tsh t_struct_SHA256state_st [_Nh] (Vint hi) c);
   `(array_at tuchar Tsh (ZnthV tuchar (map Vint (map Int.repr dd'))) 0 64
                          (offset_val (Int.repr 40) c));
   `(field_at_ Tsh t_struct_SHA256state_st [_num] c);
   `(K_vector kv);
   `(memory_block shmd (Int.repr 32) md))).

Lemma ifbody_final_if1:
  forall (Espec : OracleKind) (hashed : list int) (md c : val) (shmd : share)
  (hi lo : int) (dd : list Z) (kv: val)
 (H4: (LBLOCKz  | Zlength hashed))
 (H7: ((Zlength hashed * 4 + Zlength dd)*8 = hilo hi lo)%Z)
 (H3: Zlength dd < CBLOCKz)
 (DDbytes: Forall isbyteZ dd),
  semax Delta_final_if1
  (PROP  ()
   LOCAL
   (`(typed_true tint)
      (eval_expr
         (Ebinop Ogt (Etempvar _n tuint)
            (Ebinop Osub
               (Ebinop Omul (Econst_int (Int.repr 16) tint)
                  (Econst_int (Int.repr 4) tint) tint)
               (Econst_int (Int.repr 8) tint) tint) tint));
   `(eq (Vint (Int.repr (Zlength dd + 1)))) (eval_id _n);
   `(eq (offset_val (Int.repr 40) (force_ptr c))) (eval_id _p);
   `(eq md) (eval_id _md); `(eq c) (eval_id _c);
                     `(eq kv) (eval_var _K256 (tarray tuint CBLOCKz)))
   SEP
   (`(array_at tuint Tsh
        (ZnthV tuint (map Vint (hash_blocks init_registers hashed))) 0 8 c);
   `(field_at Tsh t_struct_SHA256state_st [_Nl] (Vint lo) c);
   `(field_at Tsh t_struct_SHA256state_st [_Nh] (Vint hi) c);
   `(array_at tuchar Tsh
       (ZnthV tuchar (map Vint (map Int.repr dd) ++ [Vint (Int.repr 128)])) 0 64
       (offset_val (Int.repr 40) c));
   `(field_at Tsh t_struct_SHA256state_st [_num] (Vint (Int.repr (Zlength dd))) c);
   `(K_vector kv);
   `(memory_block shmd (Int.repr 32) md)))
  Body_final_if1
  (normal_ret_assert (invariant_after_if1 hashed dd c md shmd hi lo kv)).
Proof.
assert (H:=True).
name md_ _md.
name c_ _c.
name p _p.
name n _n.
name cNl _cNl.
name cNh _cNh.
intros.
change 40 with data_offset.
assert (Hddlen: (0 <= Zlength dd < CBLOCKz)%Z) by Omega1.
set (ddlen := Zlength dd) in *.
 unfold Delta_final_if1; simplify_Delta; unfold Body_final_if1; abbreviate_semax.
change CBLOCKz with 64 in Hddlen.
rewrite (split_offset_array_at tuchar) with (lo := ddlen+1) (hi := 64); [|omega| simpl; omega | reflexivity].
normalize.
rename H0 into H99; rename H1 into H98.
forward_call (* memset (p+n,0,SHA_CBLOCK-n); *)
   ((Tsh,
     offset_val (Int.repr (ddlen + 1)) (offset_val (Int.repr data_offset) c)%Z,
     (CBLOCKz - (ddlen + 1)))%Z,
     Int.zero).
  {
  remember (array_at tuchar Tsh
       (fun i : Z =>
        ZnthV tuchar (map Vint (map Int.repr dd) ++ [Vint (Int.repr 128)])
          (i + (ddlen + 1))) 0 (64 - (ddlen + 1))
    (offset_val (Int.repr (data_offset + (ddlen + 1))) c))
     as A.
  entailer!.
  change CBLOCKz with 64%Z; assert (Int.max_unsigned > 64%Z) by computable; omega.
  change CBLOCKz with 64%Z.
  normalize.
   repeat rewrite <- sepcon_assoc;
    pull_left (array_at tuchar Tsh
     (fun i : Z =>
      ZnthV tuchar (map Vint (map Int.repr dd) ++ [Vint (Int.repr 128)])
        (i + (ddlen + 1))) 0 (64 - (ddlen + 1))
     (offset_val (Int.repr (data_offset + (ddlen + 1))) c)).
   repeat rewrite sepcon_assoc; apply sepcon_derives; [ | cancel].
  destruct (zlt (ddlen+1) 64).
  - rewrite memory_block_array_tuchar by Omega1.
    replace (offset_val (Int.repr (data_offset + (ddlen+1))) c)%Z
     with (offset_val (Int.repr (sizeof tuchar * (ddlen+1))) (offset_val (Int.repr 40) c))%Z
     by (normalize; Omega1).
    cancel.
 - replace (ddlen+1)%Z with 64%Z by omega. rewrite array_at_emp.
    rewrite Z.sub_diag.
   destruct c; try (contradiction Pc). simpl.
   rewrite memory_block_zero. normalize.
}
after_call.
gather_SEP 1%Z 0%Z.
pose (ddz := ((map Int.repr dd ++ [Int.repr 128]) ++ list_repeat (Z.to_nat (CBLOCKz-(ddlen+1))) Int.zero)).
replace_SEP 0%Z (  `(array_at tuchar Tsh
        (ZnthV tuchar (map Vint ddz)) 0 64
          (offset_val (Int.repr data_offset) c))).
{
 replace (Int.repr (data_offset + (ddlen+1))) with (Int.add (Int.repr data_offset) (Int.repr (ddlen+1)))
  by apply add_repr.
 entailer!.
 normalize in H2.
 change CBLOCKz with 64 in Hddlen.
 apply ltu_repr in H2; [ | Omega1 | Omega1].
 change (16*4)%Z with (CBLOCKz) in H2.
 rewrite (split_offset_array_at tuchar) with (lo := ddlen+1) (hi := 64); [| omega | simpl; omega | reflexivity].
 apply sepcon_derives.
 + entailer!. apply derives_refl'; apply equal_f; apply array_at_ext; intros.
    unfold ZnthV. if_tac; try omega.
    unfold ddz.
    repeat rewrite map_app. simpl map.
   set (dd1 :=  map Vint (map Int.repr dd) ++ [Vint (Int.repr 128)%Z]).
   rewrite app_nth1. auto.
   unfold dd1; rewrite app_length.
   unfold ddlen in *; rewrite Zlength_correct in *;
   rewrite map_length in *. simpl.
    apply Nat2Z.inj_lt. rewrite Z2Nat.id by Omega1.
  rewrite map_length; rewrite Nat2Z.inj_add; Omega1.
 +  clear - Pc_ Hddlen.
 assert (ddlen = Zlength dd) by reflexivity.
  replace (Int.repr (data_offset+(ddlen+1))%Z)
   with (Int.add  (Int.repr data_offset) (Int.repr (sizeof tuchar * (ddlen+1))))%Z
  by normalize.
 rewrite <- offset_offset_val.
 change CBLOCKz with 64%Z.
 replace (ddlen + 1 + (64 - (ddlen + 1)))%Z with 64%Z by omega.
 apply derives_refl'; apply equal_f; apply array_at_ext; intros.
 symmetry.
 unfold ZnthV. rewrite if_false by omega.
 unfold ddz. clear ddz. rewrite map_app.
 rewrite app_nth2;  rewrite map_length; rewrite app_length.
  rewrite (nth_map' Vint _ Int.zero).
 f_equal.
 apply nth_list_repeat.
  simpl. rewrite map_length, length_list_repeat.
 change CBLOCKz with 64.
 replace (length dd + 1)%nat with (Z.to_nat (ddlen + 1)).
 rewrite <- Z2Nat.inj_sub by omega.
 apply Z2Nat.inj_lt; try omega. rewrite H.
 rewrite Z2Nat.inj_add; try omega.
 rewrite Zlength_correct, Nat2Z.id. auto.
 rewrite map_length; simpl. Omega1.
}
pose (ddzw := Zlist_to_intlist (map Int.unsigned ddz)).
assert (H0': length ddz = CBLOCK). {
unfold ddz; repeat rewrite app_length.
rewrite length_list_repeat by omega.
rewrite Z2Nat.inj_sub by omega.
rewrite Z2Nat.inj_add by omega.
change (Z.to_nat CBLOCKz) with CBLOCK.
unfold ddlen; rewrite Zlength_correct.
rewrite (Nat2Z.id).
rewrite map_length; simpl length; change (Z.to_nat 1) with 1%nat.
clear - Hddlen. unfold ddlen in Hddlen.
destruct Hddlen.
rewrite Zlength_correct in H0.
change 64 with (Z.of_nat CBLOCK) in H0.
apply Nat2Z.inj_lt in H0. omega.
}
assert (H1: length ddzw = LBLOCK). {
unfold ddzw.
apply length_Zlist_to_intlist. rewrite map_length. apply H0'.
}
assert (HU: map Int.unsigned ddz = intlist_to_Zlist ddzw). {
unfold ddzw; rewrite Zlist_to_intlist_to_Zlist; auto.
rewrite map_length, H0'; exists LBLOCK; reflexivity.
unfold ddz; repeat rewrite map_app; repeat rewrite Forall_app; repeat split; auto.
apply Forall_isbyteZ_unsigned_repr; auto.
constructor. compute. clear; split; congruence.
constructor.
rewrite map_list_repeat.
apply Forall_list_repeat.
rewrite Int.unsigned_zero. split; clear; omega.
}
clear H0'.
clearbody ddzw.
 forward.  (* n=0; *)
 forward_call (* sha256_block_data_order (c,p); *)
  (hashed, ddzw, c, offset_val (Int.repr data_offset) c, Tsh, kv).
 {rewrite Zlength_correct, H1.
  entailer!.
 repeat rewrite sepcon_assoc; apply sepcon_derives; [ | cancel].
 unfold data_block.
 simpl. apply andp_right.
 apply prop_right.
 apply isbyte_intlist_to_Zlist.
 apply derives_refl'; f_equal.
 unfold tuchars. f_equal. f_equal.
 rewrite <- HU.
 rewrite map_map.
 replace (fun x => Int.repr (Int.unsigned x)) with (@id int) by
  (extensionality xx; rewrite Int.repr_unsigned; auto).
 symmetry; apply map_id.
 rewrite Zlength_correct;rewrite length_intlist_to_Zlist;
  rewrite H1; reflexivity.
}
after_call.
unfold invariant_after_if1.
change 40%Z with data_offset.
 apply exp_right with (hashed ++ ddzw).
set (pad := (CBLOCKz - (ddlen+1))%Z) in *.
 apply exp_right with (@nil Z).
 apply exp_right with pad.
entailer.
normalize in H5.
apply ltu_repr in H5; [ | split; computable
  | change CBLOCKz with 64 in Hddlen; Omega1].
simpl in H2.
assert (0 <= pad < 8)%Z.
unfold pad.
change (16*4)%Z with (CBLOCKz) in H5.
change (CBLOCKz) with CBLOCKz in H5|-*; omega.
assert (length (list_repeat (Z.to_nat pad) 0) < 8)%nat.
rewrite length_list_repeat.
apply Nat2Z.inj_lt.
rewrite Z2Nat.id by omega.
Omega1.
entailer!.
* clear; Omega1.
* rewrite initial_world.Zlength_app.
   apply Zlength_length in H1; [ | auto]. rewrite H1.
 clear - H4; destruct H4 as [n ?]; exists (n+1).
  rewrite Z.mul_add_distr_r; omega.
* rewrite <- app_nil_end.
  rewrite intlist_to_Zlist_app.
  f_equal.
  rewrite <- HU.
  unfold ddz.
  repeat rewrite map_app.
  repeat rewrite app_ass.
 f_equal.
 clear - DDbytes; induction dd; simpl.
  auto.
 inv DDbytes; f_equal; auto.
 apply Int.unsigned_repr; unfold isbyteZ in H1; repable_signed.
 rewrite map_list_repeat.
 simpl.  f_equal.
*
 unfold data_block.
 simpl. apply andp_left2.
 replace (Zlength (intlist_to_Zlist ddzw)) with 64%Z.
 apply array_at_array_at_.
 reflexivity.
 rewrite Zlength_correct; rewrite length_intlist_to_Zlist.
 rewrite H1;  reflexivity.
Qed.

Lemma nth_intlist_to_Zlist_eq:
 forall d (n i j k: nat) al, (i < n)%nat -> (i < j*4)%nat -> (i < k*4)%nat ->
    nth i (intlist_to_Zlist (firstn j al)) d = nth i (intlist_to_Zlist (firstn k al)) d.
Proof.
 induction n; destruct i,al,j,k; simpl; intros; auto; try omega.
 destruct i; auto. destruct i; auto. destruct i; auto.
 apply IHn; omega.
Qed.

Definition final_loop :=
 (Ssequence (Sset _xn (Econst_int (Int.repr 0) tint))
                 (Sloop
                    (Ssequence
                       (Sifthenelse
                          (Ebinop Olt (Etempvar _xn tuint)
                             (Ebinop Odiv (Econst_int (Int.repr 32) tint)
                                (Econst_int (Int.repr 4) tint) tint) tint)
                          Sskip Sbreak)
                       (Ssequence
                          (Sset _ll
                             (Ederef
                                (Ebinop Oadd
                                   (Efield
                                      (Ederef
                                         (Etempvar _c
                                            (tptr t_struct_SHA256state_st))
                                         t_struct_SHA256state_st) _h
                                      (tarray tuint 8)) (Etempvar _xn tuint)
                                   (tptr tuint)) tuint))
                          (Ssequence
                             (Scall None
                                (Evar ___builtin_write32_reversed
                                   (Tfunction
                                      (Tcons (tptr tuint) (Tcons tuint Tnil))
                                      tvoid cc_default))
                                [Ecast (Etempvar _md (tptr tuchar))
                                   (tptr tuint), Etempvar _ll tuint])
                             (Sset _md
                                (Ebinop Oadd (Etempvar _md (tptr tuchar))
                                   (Econst_int (Int.repr 4) tint)
                                   (tptr tuchar))))))
                    (Sset _xn
                       (Ebinop Oadd (Etempvar _xn tuint)
                          (Econst_int (Int.repr 1) tint) tuint)))).

Lemma nth_intlist_to_Zlist_first_hack:
  forall  j i al,
    (i*4 <= j)%nat ->
    nth (j-i*4) (intlist_to_Zlist [nth i al Int.zero]) 0 =
    nth j (intlist_to_Zlist (firstn (S i) al)) 0.
Proof.
intros.
 assert (j= (j-i*4) + i*4)%nat by omega.
 rewrite H0 at 2.
 forget (j-i*4)%nat as n. clear.
 revert n al; induction i; intros.
 change (0*4)%nat with O.
 rewrite NPeano.Nat.add_0_r.
 destruct al; try reflexivity.
 simpl firstn.
 rewrite (nth_overflow nil) by (simpl; auto).
 simpl intlist_to_Zlist.
 repeat (destruct n; try reflexivity).
 replace (n + S i * 4)%nat with (n+4 + i*4)%nat
  by (simpl; omega).
 destruct al as [ | a al].
 rewrite (nth_overflow nil) by (simpl; clear; omega).
 simpl firstn. simpl intlist_to_Zlist.
 rewrite (nth_overflow nil) by (simpl; clear; omega).
 repeat (destruct n; try reflexivity).
 simpl nth at 2.
 replace (firstn (S (S i)) (a :: al)) with (a :: firstn (S i) al).
 unfold intlist_to_Zlist at 2; fold intlist_to_Zlist.
 rewrite IHi. clear IHi.
 replace (n + 4 + i*4)%nat with (S (S (S (S (n + i*4)))))%nat by omega.
 reflexivity.
 clear.
 forget (S i) as j.
 revert al; induction j; simpl; intros; auto.
Qed.

Lemma final_part4:
 forall (Espec: OracleKind) md c shmd hashedmsg kv,
 length hashedmsg = 8%nat ->
 writable_share shmd ->
semax
  (initialized _cNl (initialized _cNh Delta_final_if1))
  (PROP  ()
   LOCAL  (`(eq md) (eval_id _md); `(eq c) (eval_id _c))
   SEP
   (`(array_at tuchar Tsh (fun _ : Z => Vint Int.zero) 0 64
        (offset_val (Int.repr data_offset) c));
   `(array_at tuint Tsh (tuints hashedmsg) 0 8 c);
   `(K_vector kv);
   `(field_at_ Tsh t_struct_SHA256state_st [_Nl] c);
   `(field_at_ Tsh t_struct_SHA256state_st [_Nh] c);
   `(field_at Tsh t_struct_SHA256state_st [_num] (Vint (Int.repr 0)) c);
   `(memory_block shmd (Int.repr 32) md)))
  (Ssequence final_loop (Sreturn None))
  (function_body_ret_assert tvoid
     (PROP  ()
      LOCAL ()
      SEP  (`(K_vector kv);
      `(data_at_ Tsh t_struct_SHA256state_st c);
      `(data_block shmd (intlist_to_Zlist hashedmsg) md)))).
Proof.
intros.
unfold final_loop; abbreviate_semax.
rewrite memory_block_isptr.
normalize. rename H1 into Hmd.
forward.  (* xn=0; *)

Definition part4_inv  c shmd hashedmsg md kv delta (i: nat) :=
   (PROP  ((i <= 8)%nat)
   LOCAL  (`(eq (Vint (Int.repr (Z.of_nat i - delta)))) (eval_id _xn);
      `(eq (offset_val (Int.repr (Z.of_nat i * 4)) md)) (eval_id _md);
   `(eq c) (eval_id _c))
   SEP
   (`(array_at tuchar Tsh (fun _ : Z => Vint Int.zero) 0 64
        (offset_val (Int.repr data_offset) c));
   `(array_at tuint Tsh (tuints hashedmsg) 0 8 c);
   `(K_vector kv);
   `(field_at_ Tsh t_struct_SHA256state_st [_Nl] c);
   `(field_at_ Tsh t_struct_SHA256state_st [_Nh] c);
   `(field_at Tsh t_struct_SHA256state_st [_num] (Vint (Int.repr 0)) c);
   `(array_at tuchar shmd (tuchars (map Int.repr (intlist_to_Zlist (firstn i hashedmsg))))
              0 32 md))).

forward_for
   (EX i:_, part4_inv c shmd hashedmsg md kv 0 i)
   (EX i:_, part4_inv c shmd hashedmsg md kv 1 i)
   (part4_inv c shmd hashedmsg md kv 0 8).
* apply exp_right with 0%nat. unfold part4_inv; rewrite Z.sub_0_r.
  entailer!.
  change 32%Z with (sizeof (tarray tuchar 32)).
  apply derives_trans with (data_at_ shmd (tarray tuchar 32) _id0).
  rewrite <- memory_block_data_at_ by reflexivity.
  unfold align_compatible.
  simpl (alignof (tarray tuchar 32)).
  simpl.
  destruct _id0; inversion Hmd. assert (1 | Int.unsigned i) by apply Z.divide_1_l.
  entailer!.
  unfold data_at_.
  unfold_data_at 1%nat.
  normalize.
* quick_typecheck.
* unfold part4_inv.  repeat rewrite Z.sub_0_r.
  rewrite (firstn_same _ 8) by omega.
  entailer.
  rewrite <- H2 in *.
  simpl in H5.
 simpl_compare.
 change (Int.divs (Int.repr 32) (Int.repr 4)) with (Int.repr 8) in H5.
 apply ltu_repr_false in H5; try repable_signed; try omega.
 assert (i=8)%nat by omega.
 subst i. change (Z.of_nat 8) with 8%Z.
 entailer!.
  rewrite (firstn_same _ 8) by omega. auto.
* unfold part4_inv.
 rewrite insert_local.
 match goal with |- semax _ (PROPx _ (LOCALx (_:: ?Q) ?R)) _ _ =>
   apply semax_pre with (PROP ((i<8)%nat) (LOCALx Q R))
  end.
 rewrite Z.sub_0_r.
 entailer!.
 change (Int.divs (Int.repr 32) (Int.repr 4)) with (Int.repr 8) in H2.
 apply ltu_repr in H2; try repable_signed; try omega.
 normalize.
 rewrite Z.sub_0_r.
 forward. (* ll=(c)->h[xn]; *)
  entailer!.
  omega.
  unfold tuints, ZnthV. rewrite if_false by omega.
  rewrite Nat2Z.id.
  rewrite (nth_map' Vint _ Int.zero).
  apply I.
  omega.
 pose (w := nth i hashedmsg Int.zero).
 pose (bytes := Basics.compose force_int (ZnthV tuchar (map Vint (map Int.repr (intlist_to_Zlist [w]))))).
  forward_call (* builtin_write32_reversed *)
     (offset_val (Int.repr (Z.of_nat i * 4)) md, shmd, bytes).
 entailer!.
  rewrite Int.signed_repr in H3 by repable_signed.
  auto.
 destruct md; try (contradiction Hmd); reflexivity.
 unfold tuints, ZnthV in H3.
 rewrite Int.signed_repr in H3 by repable_signed.
  rewrite if_false in H3 by omega.
 rewrite Nat2Z.id in H3.
 rewrite (nth_map' _ _ Int.zero) in H3 by omega.
 inv H3.
 symmetry; unfold bytes, Basics.compose;
 replace (fun x : Z =>
   force_int
     (ZnthV tuchar
        (map Vint (map Int.repr (intlist_to_Zlist [w]))) x))
  with
  (fun x : Z =>
   force_int
     (ZnthV tuchar
        (map Vint (map Int.repr (intlist_to_Zlist [w])))
              (x + Z.of_nat O * 4)))
 by (extensionality j; repeat f_equal; simpl; apply Z.add_0_r).
 apply nth_big_endian_integer.
 reflexivity.
{
 entailer.
 replace (memory_block shmd (Int.repr 4)) with ((fun p : val => !!align_compatible (tarray tuchar 4) p) && memory_block shmd (Int.repr (sizeof (tarray tuchar 4)))).
 Focus 2. {
   extensionality p. simpl.
   rewrite andp_comm, <- add_andp; auto.
   apply prop_right; unfold align_compatible; simpl.
   destruct p; auto; apply Z.divide_1_l.
 } Unfocus.
  rewrite memory_block_data_at_ by reflexivity.
  unfold data_at_.
  unfold tarray.
  erewrite data_at_array_at; [| reflexivity | simpl; omega | reflexivity].
 rewrite (split_array_at (Z.of_nat (S i) * 4)%Z tuchar _ _ _ 32 md)
   by (rewrite inj_S; split; omega).
 assert (Z.of_nat (S i) * 4 = Z.of_nat i * 4 + 4)%Z.
   rewrite inj_S. unfold Z.succ.
   rewrite Z.mul_add_distr_r. reflexivity.
 erewrite (split_offset_array_at tuchar shmd) with (lo := (Z.of_nat i * 4)%Z);
 [| omega | simpl; omega | reflexivity].
 normalize.
 pull_left (array_at tuchar shmd
     (fun i0 : Z =>
      tuchars (map Int.repr (intlist_to_Zlist (firstn i hashedmsg)))
        (i0 + Z.of_nat i * 4)) 0 (Z.of_nat (S i) * 4 - Z.of_nat i * 4)
     (offset_val (Int.repr (Z.of_nat i * 4)) md)).
 repeat rewrite sepcon_assoc; apply sepcon_derives; [ | cancel_frame].
 replace (offset_val (Int.repr (Z.of_nat i * 4)))
   with (offset_val (Int.repr (sizeof tuchar * (Z.of_nat i * 4))))
  by (f_equal; f_equal; apply Z.mul_1_l).
 rewrite array_at_ZnthV_nil.

 rewrite H4.
 replace ((Z.of_nat i * 4 + 4 - Z.of_nat i * 4)) with 4 by omega.
 apply array_at_array_at_; reflexivity.
}
 after_call.
 normalize.
 forward. (* md += 4; *)
 entailer!.
 unfold loop1_ret_assert;  simpl update_tycon.
 unfold part4_inv. apply exp_right with (S i). rewrite inj_S.
{
 entailer!.
 f_equal; omega.
 destruct md; try (contradiction Hmd); simpl; f_equal.
 f_equal. f_equal.
 unfold Z.succ. rewrite Z.mul_add_distr_r. reflexivity.
 replace (match hashedmsg with
               | [] => []
               | a :: l => a :: firstn i l
               end) with (firstn (S i) hashedmsg)
  by (clear; destruct hashedmsg; auto).
 rewrite (split_array_at (Z.of_nat (S i) * 4)%Z tuchar _ _ 0 32 md)
   by (rewrite inj_S; split; omega).
 assert (Z.of_nat (S i) * 4 = Z.of_nat i * 4 + 4)%Z as H99.
   rewrite inj_S. unfold Z.succ.
   rewrite Z.mul_add_distr_r. reflexivity.
 erewrite (split_offset_array_at tuchar shmd) with (lo := (Z.of_nat i * 4)%Z) (hi := (Z.of_nat (S i) * 4)%Z);
 [| omega | simpl; omega | reflexivity].
 repeat rewrite <- sepcon_assoc.
 pull_left (array_at tuchar shmd
  (tuchars (map Int.repr (intlist_to_Zlist (firstn i hashedmsg)))) 0
  (Z.of_nat i * 4) md).
 replace (Z.succ (Z.of_nat i)) with (Z.of_nat (S i)) by apply Nat2Z.inj_succ.
 rewrite (add_andp (array_at tuchar shmd
     (tuchars (map Int.repr (intlist_to_Zlist (firstn i hashedmsg))))
     (Z.of_nat (S i) * 4) 32 md) (!!offset_in_range (sizeof tuchar * (Z.of_nat (S i) * 4)) md)) by
   (unfold array_at; normalize).
 rewrite (add_andp (array_at tuchar shmd
     (tuchars (map Int.repr (intlist_to_Zlist (firstn i hashedmsg))))
     (Z.of_nat (S i) * 4) 32 md) (!!offset_in_range (sizeof tuchar * 0) md)) by
    ( apply prop_right; unfold offset_in_range; destruct md; auto;
    pose proof Int.unsigned_range i0; omega).
 normalize.
 rename H3 into H98; rename H4 into H97.
 repeat apply sepcon_derives; auto.
 +
 apply derives_refl'; apply equal_f; apply array_at_ext; intros.
 unfold tuchars, ZnthV. rewrite if_false by omega.
 rewrite if_false by omega.
 rewrite map_map. rewrite map_map.
 rewrite (nth_map' _ _ 0%Z).
Focus 2.
 clear - H3 H H1. rewrite length_intlist_to_Zlist. rewrite firstn_length.
  rewrite min_l by omega. destruct H3.
  apply Nat2Z.inj_lt. rewrite Z2Nat.id by omega.
  rewrite Nat2Z.inj_mul; rewrite Z.mul_comm; auto.
 rewrite (nth_map' _ _ 0%Z).
Focus 2. clear - H3 H H1. rewrite length_intlist_to_Zlist. rewrite firstn_length.
  rewrite min_l by omega. destruct H3.
  apply Nat2Z.inj_lt. rewrite Z2Nat.id by omega.
  rewrite Nat2Z.inj_mul.
 rewrite Z.mul_comm; rewrite inj_S.
 unfold Z.succ; rewrite Z.mul_add_distr_r.
 change (1 * Z.of_nat 4) with 4.  change (Z.of_nat 4) with 4; omega.
 do 2 f_equal.
apply (nth_intlist_to_Zlist_eq _ (S (Z.to_nat i0))); try omega.
 apply Nat2Z.inj_lt. rewrite Z2Nat.id by (clear - H3; omega).
  rewrite Nat2Z.inj_mul; apply H3.
 apply Nat2Z.inj_lt. rewrite Z2Nat.id by (clear - H3; omega).
 clear - H3; rewrite Nat2Z.inj_mul; rewrite inj_S;
  unfold Z.succ; rewrite Z.mul_add_distr_r.
  change (Z.of_nat 4) with 4; omega.
+ rewrite H99.
  replace (Z.of_nat i * 4 + 4 - Z.of_nat i * 4) with 4 by omega.
 apply derives_refl'; apply equal_f; apply array_at_ext; intros.
 unfold cVint, bytes, tuchars, ZnthV, Basics.compose.
 rewrite if_false by omega. rewrite if_false by omega.
 repeat rewrite map_map.
 rewrite (nth_map' _ _ 0).
Focus 2.
 simpl. apply Nat2Z.inj_lt. rewrite Z2Nat.id by omega.
 change (Z.of_nat 4) with 4; omega.
 rewrite (nth_map' _ _ 0).
Focus 2. clear - H99 H3 H H1. rewrite length_intlist_to_Zlist.
 rewrite firstn_length;  rewrite min_l by omega. destruct H3.
  apply Nat2Z.inj_lt. rewrite Z2Nat.id by omega.
  rewrite Nat2Z.inj_mul.
 rewrite Z.mul_comm; rewrite inj_S.
 unfold Z.succ. change (Z.of_nat 3 + 1) with 4. omega.
 unfold force_int. f_equal. f_equal.
 clear - H3.

 unfold w; clear w.
  change 4 with (Z.of_nat 4). rewrite <- Nat2Z.inj_mul.
 replace (Z.to_nat i0) with (Z.to_nat i0 + i * 4 - i * 4)%nat by omega.
 replace (Z.to_nat (i0 + Z.of_nat (i * 4))) with (Z.to_nat i0 + i * 4)%nat by
   (rewrite Z2Nat.inj_add by omega; rewrite Nat2Z.id; reflexivity).
 apply nth_intlist_to_Zlist_first_hack; auto.
 omega.

+
 rewrite inj_S.
 apply derives_refl'; apply equal_f; apply array_at_ext; intros.
 unfold tuchars, ZnthV. rewrite if_false by omega.
 rewrite if_false by omega.
 rewrite map_map. rewrite map_map.
 rewrite nth_overflow.
Focus 2. {
  rewrite map_length, length_intlist_to_Zlist, firstn_length.
   rewrite min_l by omega.
  unfold Z.succ in H3.
  destruct H3 as [H4 _].
 apply Z2Nat.inj_le in H4; try omega.
 rewrite Z.mul_add_distr_r in H4.
 rewrite Z2Nat.inj_add in H4 by omega.
 change (Z.to_nat (1*4)) with 4%nat in H4.
 rewrite mult_comm.
 replace (i*4)%nat with (Z.to_nat (Z.of_nat i * 4)); [omega | ].
 clear. change 4 with (Z.of_nat 4); rewrite <- Nat2Z.inj_mul;
  rewrite Nat2Z.id; auto.
} Unfocus.
 rewrite nth_overflow; [reflexivity | ]. {
 rewrite map_length, length_intlist_to_Zlist, firstn_length.
  rewrite min_l by omega.
 clear - H3 H H1.
 destruct H3 as [H4 _].
 apply Z2Nat.inj_le in H4; try omega.
 unfold Z.succ in H4.
 rewrite Z.mul_add_distr_r in H4.
 rewrite Z.mul_1_l in H4.
 change 4 with (Z.of_nat 4) in H4.
 rewrite <- Nat2Z.inj_mul, <- Nat2Z.inj_add in H4.
 rewrite Nat2Z.id in H4.
 rewrite mult_comm.
 replace (S i) with (i+1)%nat by omega.
 rewrite  NPeano.Nat.mul_add_distr_r.
 apply H4.
}
}
* (* for-loop increment *)
 unfold part4_inv. apply extract_exists_pre; intro i.
 normalize.
 forward. (* xn++; *)
 apply exp_right with i.
 unfold part4_inv.
 rewrite Z.sub_0_r.
 entailer.
 apply prop_right. f_equal. omega.
* (* after the loop *)
 unfold part4_inv.
  rewrite (firstn_same _ 8) by omega.
 forward. (* return; *)
 unfold data_at_.
 unfold_data_at 1%nat.
 unfold_field_at 2%nat.
 unfold_field_at 4%nat.
 repeat rewrite array_at_ZnthV_nil.
 unfold at_offset.  unfold data_block.
 rewrite prop_true_andp with (P:= Forall isbyteZ (intlist_to_Zlist hashedmsg)) by apply isbyte_intlist_to_Zlist.
 replace (Zlength (intlist_to_Zlist hashedmsg)) with 32%Z.
 cancel.
 unfold field_at.
 simpl. entailer!.
 unfold at_offset.
 eapply derives_trans; [apply mapsto_mapsto_| auto].
 rewrite Zlength_correct; rewrite length_intlist_to_Zlist; rewrite H; reflexivity.
Qed.


Require Import LambdaANF.cps LambdaANF.identifiers LambdaANF.ctx LambdaANF.set_util LambdaANF.state
        LambdaANF.dead_param_elim LambdaANF.Ensembles_util LambdaANF.tactics LambdaANF.map_util
        LambdaANF.hoisting.
Require Import compcert.lib.Coqlib Common.compM Common.Pipeline_utils.
Require Import Coq.Lists.List Coq.MSets.MSets Coq.MSets.MSetRBT Coq.Numbers.BinNums
        Coq.NArith.BinNat Coq.PArith.BinPos Coq.Sets.Ensembles micromega.Lia
        maps_util.
Require Import ExtLib.Structures.Monads ExtLib.Data.Monads.StateMonad.
Import ListNotations Nnat.

Import MonadNotation.
Open Scope monad_scope.

Open Scope ctx_scope.
Open Scope fun_scope.
Close Scope Z_scope.

Inductive Dead_in_args (S : Ensemble var) : list var -> list bool -> Prop :=
| Live_nil : Dead_in_args S [] []
| ALive_cons_Dead :
    forall (x : var) (xs : list var) (bs: list bool),
      Dead_in_args S xs bs ->
      Dead_in_args S (x :: xs) (false :: bs)
| ALive_cons_Live :
    forall (x : var) (xs : list var) (bs: list bool),
      Dead_in_args S xs bs ->
      ~ x \in S ->
      Dead_in_args S (x :: xs) (true :: bs).

Fixpoint dead_args (ys : list var) (bs : list bool) : list var :=
  match ys, bs with
  | [], [] => ys
  | y :: ys', b :: bs' =>
    if b then (dead_args ys' bs')
    else y :: dead_args ys' bs'
| _, _ => []
end.

Inductive Dead (S : Ensemble var) (L : live_fun) : exp -> Prop :=
| Live_Constr :
    forall (x : var) (ys : list var) (ct : ctor_tag) (e : exp),
      Disjoint _ (FromList ys) S ->
      Dead S L e ->
      Dead S L (Econstr x ct ys e)
| Live_Prim_val :
  forall (x : var) p (e : exp),
    Dead S L e ->
    Dead S L (Eprim_val x p e)
| Live_Prim :
  forall (x : var) (g : prim) (ys : list var) (e : exp),
    Disjoint _ (FromList ys) S ->
    Dead S L e ->
    Dead S L (Eprim x g ys e)
| Live_Proj :
    forall (x : var) (ct : ctor_tag) (n : N) (y : var) (e : exp),
      ~ y \in S ->
     Dead S L e ->
     Dead S L (Eproj x ct n y e)
| Live_Case:
    forall (x : var) (ce : list (ctor_tag * exp)),
      ~ x \in S ->
      Forall (fun p => Dead S L (snd p)) ce ->
      Dead S L (Ecase x ce)
| Live_Halt :
    forall (x : var),
      ~ x \in S ->
      Dead S L (Ehalt x)
| Live_App_Unknown :
    forall (f : var) (ys : list var) (ft : fun_tag),
      ~ f \in S ->
      Disjoint _ (FromList ys) S ->
      L ! f = None ->
      Dead S L (Eapp f ft ys)
| Live_App_Known :
    forall (f : var) (ys : list var) (ft : fun_tag) (bs : list bool),
      L ! f = Some bs ->
      ~ f \in S ->
      Disjoint _ S (FromList (live_args ys bs)) ->
      Dead S L (Eapp f ft ys)
| Live_LetApp_Unknown :
    forall (x f : var) (ys : list var) (ft : fun_tag) (e : exp),
      ~ f \in S ->
      Disjoint _ (FromList ys) S ->
      L ! f = None ->
      Dead S L e ->
      Dead S L (Eletapp x f ft ys e)
| Live_LetApp_Known :
    forall (x f : var) (ys : list var) (ft : fun_tag) (e : exp) (bs : list bool),
      L ! f = Some bs ->
      ~ f \in S ->
      Disjoint _ S (FromList (live_args ys bs)) ->
      Dead S L e ->
      Dead S L (Eletapp x f ft ys e).

Definition live_map_sound (B : fundefs) (L : live_fun) :=
  forall f ft xs e bs,
    fun_in_fundefs B (f, ft, xs, e) ->
    L ! f = Some bs ->
    Dead (FromList (dead_args xs bs)) L e.

Definition live_fun_args (L : live_fun) (f : var) (xs : list var) :=
  exists bs, L ! f = Some bs /\ length xs = length bs.

Definition live_fun_consistent (L : live_fun) (B : fundefs) :=
  forall f ft xs e,
    fun_in_fundefs B (f, ft, xs, e) ->
    live_fun_args L f xs.

(* Lemmas about [live] *)

Lemma live_diff B L L' d :
  live B L d = (L', false) ->
  d = false.
Proof.
  revert L L' d. induction B; simpl; intros L L' d Hl; eauto.
  - destruct (update_live_fun L v l (live_expr L e PS.empty)) as [L'' d''].
    eapply IHB in Hl. destruct d; eauto. destruct d''; eauto.
  - inv Hl; eauto.
Qed.

Lemma update_live_fun_false L L' f xs S :
  update_live_fun L f xs S = (L', false) ->
  L = L' /\
  (forall bs,
      get_fun_vars L f = Some bs ->
      Disjoint _ (FromSet S) (FromList (dead_args xs bs))).
Proof.
  intros Hl.
  unfold update_live_fun in Hl.
  destruct (get_fun_vars L f) eqn:Hf.
  - unfold get_fun_vars in *.
    destruct (update_bs S xs l) as [bs diff] eqn:Hupd.
    inv Hl.
    destruct diff. congruence. inv H0.
    split. reflexivity.
    intros bs' Hget. inv Hget.

    assert (Hsuff : Disjoint  positive (FromSet S) (FromList (dead_args xs bs'))).
    { clear Hf. revert bs bs' Hupd.
      induction xs; intros bs bs' Hupd.
      - inv Hupd.
        destruct bs; eauto; simpl; normalize_sets; sets.
      - destruct bs'.
        { simpl. normalize_sets; sets. }
        simpl in *.

        destruct (update_bs S xs bs') eqn:Hup.
        destruct b. inv Hupd.
        * eapply IHxs. eassumption.
        * inv Hupd.
          eapply orb_false_iff in H1. inv H1.
          destruct (PS.mem a S) eqn:Hmem. now inv H. clear H.
          specialize (IHxs l bs' Hup).
          normalize_sets. eapply Union_Disjoint_r; [| eassumption ].
          eapply Disjoint_Singleton_r.
          intros Hc. eapply FromSet_sound in Hc; [| reflexivity ].
          eapply PS.mem_spec in Hc. congruence. }
    eassumption.

  - inv Hl. split; eauto. congruence.
Qed.

Lemma add_fun_vars_subset L v l Q :
  FromSet Q \subset FromSet (add_fun_vars L v l Q).
Proof.
  unfold add_fun_vars.
  destruct (get_fun_vars L v); rewrite FromSet_union_list; sets.
Qed.

Lemma live_expr_subset L e Q :
  FromSet Q \subset FromSet (live_expr L e Q).
Proof.
  revert Q; induction e using exp_ind'; intros Q; simpl;
    try now (eapply Included_trans; [| eapply IHe ]; rewrite FromSet_union_list; sets).
  - rewrite FromSet_add; sets.
  - simpl in *. rewrite !FromSet_add. setoid_rewrite FromSet_add in IHe0.
    eapply Included_trans; [| eapply IHe0 ].
    eapply IHe.
  - eapply Included_trans; [| eapply IHe ].
    rewrite FromSet_add; sets.
  - eapply Included_trans; [| eapply IHe ].
    eapply Included_trans; [| eapply add_fun_vars_subset ].
    rewrite !FromSet_add; sets.
  - sets.
  - eapply Included_trans; [| eapply add_fun_vars_subset ].
    rewrite FromSet_add; sets.
  - auto.
  - rewrite FromSet_add; sets.
Qed.

Lemma fold_left_live_expr_subset L S (P : list (ctor_tag * exp)) :
  FromSet S \subset FromSet (fold_left (fun (S : PS.t) '(_, e') => live_expr L e' S) P S).
Proof.
  revert S. induction P; simpl; intros; sets.
  destruct a. eapply Included_trans; [| eapply IHP ].
  eapply live_expr_subset.
Qed.

Lemma live_args_subset {A} (ys : list A) bs:
  FromList (live_args ys bs) \subset FromList ys.
Proof.
  revert bs; induction ys; intros [ | [|] bs ]; simpl; sets.
  - repeat normalize_sets. sets.
  - repeat normalize_sets. sets.
Qed.

Lemma live_expr_sound Q L e S :
  no_fun e ->
  Disjoint _ (FromSet (live_expr L e Q)) S ->
  Dead S L e.
Proof.
  revert Q; induction e using exp_ind'; intros Q; simpl; intros Hnf Hdis; inv Hnf.
  - econstructor.
    + repeat normalize_bound_var_in_ctx. repeat normalize_occurs_free_in_ctx.
      eapply Disjoint_Included_l; [| eassumption ].
      eapply Included_trans; [| eapply live_expr_subset ].
      rewrite FromSet_union_list. sets.
    + eapply IHe; eauto.
  - rewrite FromSet_add in *.
    econstructor; eauto. intros Hc.
    eapply Hdis. econstructor; eauto.
  - rewrite FromSet_add in *. econstructor.
    + intros Hc. eapply Hdis. econstructor; eauto.
    + econstructor. eapply IHe; eauto.
      * eapply Disjoint_Included_l; [| eassumption ].
        eapply Included_Union_preserv_r.
        eapply fold_left_live_expr_subset.
      * assert (Hsuff : Dead S L (Ecase v l)).
        { eapply IHe0; eauto.
          eapply Disjoint_Included_l; [| eassumption ].
          simpl. rewrite FromSet_add. sets. }
        inv Hsuff. eassumption.
  - econstructor.
    + repeat normalize_bound_var_in_ctx. repeat normalize_occurs_free_in_ctx.
      intros Hc.
      eapply Hdis; eauto. econstructor; eauto. eapply live_expr_subset.
      rewrite FromSet_add. sets.
    + eapply IHe; eauto.
  - destruct (L ! f) eqn:Heq.
    + eapply Live_LetApp_Known. eassumption.
      * intros Hc. eapply Hdis. constructor; eauto.
        eapply live_expr_subset.
        eapply add_fun_vars_subset. rewrite FromSet_add. sets.
      * repeat normalize_bound_var_in_ctx. repeat normalize_occurs_free_in_ctx.
        eapply Disjoint_sym. eapply Disjoint_Included_l; [| eassumption ].
        eapply Included_trans; [| eapply live_expr_subset ].
        unfold add_fun_vars, get_fun_vars. rewrite Heq.
        rewrite FromSet_union_list.  sets.
      * eapply IHe; eauto.
    + eapply Live_LetApp_Unknown; eauto.
      * intros Hc. eapply Hdis. constructor; eauto.
        eapply live_expr_subset.
        eapply add_fun_vars_subset. rewrite FromSet_add. sets.
      * repeat normalize_bound_var_in_ctx. repeat normalize_occurs_free_in_ctx.
        eapply Disjoint_Included_l; [| eassumption ].
        eapply Included_trans; [| eapply live_expr_subset ].
        unfold add_fun_vars. unfold get_fun_vars. rewrite Heq.
        rewrite FromSet_union_list. sets.
  - destruct (L ! v) eqn:Heq.
    + eapply Live_App_Known. eassumption.
      * intros Hc. eapply Hdis. constructor; eauto.
        eapply add_fun_vars_subset. rewrite FromSet_add. sets.
      * repeat normalize_bound_var_in_ctx. repeat normalize_occurs_free_in_ctx.
        eapply Disjoint_sym. eapply Disjoint_Included_l; [| eassumption ].
        unfold add_fun_vars, get_fun_vars. rewrite Heq.
        rewrite FromSet_union_list.  sets.
    + eapply Live_App_Unknown; eauto.
      * intros Hc. eapply Hdis. constructor; eauto.
        eapply add_fun_vars_subset. rewrite FromSet_add. sets.
      * repeat normalize_bound_var_in_ctx. repeat normalize_occurs_free_in_ctx.
        eapply Disjoint_Included_l; [| eassumption ].
        unfold add_fun_vars. unfold get_fun_vars. rewrite Heq.
        rewrite FromSet_union_list. sets.
  - econstructor; eauto.
  - econstructor.
    + repeat normalize_bound_var_in_ctx. repeat normalize_occurs_free_in_ctx.
      eapply Disjoint_Included_l; [| eassumption ].
      eapply Included_trans; [| eapply live_expr_subset ].
      rewrite FromSet_union_list. sets.
    + eapply IHe; eauto.
  - econstructor.
    + repeat normalize_bound_var_in_ctx. repeat normalize_occurs_free_in_ctx.
      intros Hc. eapply Hdis. constructor; eauto.
      rewrite FromSet_add. now sets.
Qed.

Lemma live_correct L L' B :
  no_fun_defs B -> (* no nested functions in B *)
  live B L false = (L', false) ->
  L = L' /\ live_map_sound B L.
Proof.
  revert L L'; induction B; simpl; intros L L' Hnf Hl.
  - destruct (update_live_fun L v l (live_expr L e PS.empty)) as [L'' b] eqn:Heq.

    assert (Hd := live_diff _ _ _ _ Hl). destruct b; inv Hd.
    simpl in *.

    edestruct update_live_fun_false; try eassumption.

    destructAll.

    eapply IHB in Hl. inv Hl.

    split. reflexivity.

    { intro; intros. inv H.
      - inv H3. eapply live_expr_sound. inv Hnf. eassumption.
        unfold get_fun_vars in *. eapply H0. eassumption.
      - eapply H1. eassumption. eassumption. }

    inv Hnf. eassumption.

  - inv Hl. split; eauto.
    intro; intros. inv H.
Qed.

(* Proof that a fixpoint is reached in n steps *)

Fixpoint bitsize (bs : list bool) :=
  match bs with
  | [] => 0
  | b :: bs => if b then 1 + bitsize bs else bitsize bs
  end.

Definition map_size (L : live_fun) :=
  fold_left (fun s '(_, bs) => s + bitsize bs) (M.elements L) 0.

Definition max_map_size (L : live_fun) :=
  fold_left (fun s '(_, bs) => s + length bs) (M.elements L) 0.

Lemma update_bs_bitsize_leq S xs bs bs' diff :
  update_bs S xs bs = (bs', diff) ->
  bitsize bs <= bitsize bs'.
Proof.
  revert S bs bs' diff. induction xs; simpl; intros S bs bs' diff Hupd.
  - inv Hupd. reflexivity.
  - destruct bs.
    + inv Hupd. reflexivity.
    + destruct (update_bs S xs bs) as [bs'' d] eqn:Hupd'.
      destruct b.
      * inv Hupd. simpl. eapply IHxs in Hupd'. lia.
      * inv Hupd. eapply IHxs in Hupd'. simpl.
        destruct (PS.mem a S); lia.
Qed.

Lemma update_bs_bitsize S xs bs bs' :
  update_bs S xs bs = (bs', true) ->
  bitsize bs < bitsize bs'.
Proof.
  revert S bs bs'. induction xs; simpl; intros S bs bs' Hupd.
  - inv Hupd.
  - destruct bs.
    + inv Hupd.
    + destruct (update_bs S xs bs) as [bs'' d] eqn:Hupd'.
      destruct b.
      * inv Hupd. simpl. eapply IHxs in Hupd'. lia.
      * inv Hupd. simpl.
        destruct (PS.mem a S).
        -- eapply update_bs_bitsize_leq in Hupd'. lia.
        -- simpl in H1. subst. eapply IHxs. eassumption.
Qed.

Lemma update_bs_length S xs bs bs' diff :
  update_bs S xs bs = (bs', diff) ->
  length bs = length bs'.
Proof.
  revert S bs bs' diff. induction xs; simpl; intros S bs bs' diff Hupd.
  - inv Hupd. reflexivity.
  - destruct bs.
    + inv Hupd. reflexivity.
    + destruct (update_bs S xs bs) as [bs'' d] eqn:Hupd'.
      destruct b.
      * inv Hupd. simpl. eapply IHxs in Hupd'. lia.
      * inv Hupd. simpl.
        eapply IHxs in Hupd'. congruence.
Qed.

Lemma set_fun_vars_map_size L f l bs :
  L ! f = Some l ->
  length l = length bs ->
  map_size L + bitsize bs =  map_size (set_fun_vars L f bs) + bitsize l.
Proof.
  intros Heq Hlen. unfold set_fun_vars.

  unfold map_size.
  edestruct elements_set_some. eassumption.
  destructAll.
  rewrite H, H0.
  rewrite !fold_left_app. simpl.
  rewrite <- (plus_O_n (fold_left _ _ _ + bitsize l)).
  rewrite <- (plus_O_n (fold_left _ x 0 + bitsize bs)).
  erewrite !List_util.fold_left_acc_plus. simpl. lia.

  intros ? ? [? ? ]. lia.
  intros ? ? [? ? ]. lia.
Qed.

Lemma update_live_fun_size_leq L L' b f xs S :
  update_live_fun L f xs S = (L', b) ->
  map_size L <= map_size L'.
Proof.
  intros Hl.
  unfold update_live_fun in Hl.
  destruct (get_fun_vars L f) eqn:Hf.
  unfold get_fun_vars in *.
  destruct (update_bs S xs l) as [bs diff] eqn:Hupd.
  destruct diff.

  - inv Hl. assert (Hupd' := Hupd). eapply update_bs_bitsize in Hupd.
    eapply set_fun_vars_map_size with (bs := bs) in Hf. lia.
    eapply update_bs_length. eassumption.
  - inv Hl. reflexivity.
  - inv Hl. reflexivity.
Qed.

Lemma update_live_fun_size L L' f xs S :
  update_live_fun L f xs S = (L', true) ->
  map_size L < map_size L'.
Proof.
  intros Hl.
  unfold update_live_fun in Hl.
  destruct (get_fun_vars L f) eqn:Hf; try congruence.
  unfold get_fun_vars in *.
  destruct (update_bs S xs l) as [bs diff] eqn:Hupd.
  destruct diff.

  - inv Hl. assert (Hupd' := Hupd). eapply update_bs_bitsize in Hupd.
    eapply set_fun_vars_map_size with (bs := bs) in Hf. lia.
    eapply update_bs_length. eassumption.
  - inv Hl.
Qed.

Lemma live_size_leq L L' d d' B :
  live B L d = (L', d') ->
  map_size L <= map_size L'.
Proof.
  revert L L' d d'; induction B; simpl; intros L L' d d' Hl; subst.
  - destruct (update_live_fun L v l (live_expr L e PS.empty)) as [L'' b] eqn:Heq.
    destruct b; simpl in *.
    + eapply le_trans.
      eapply update_live_fun_size_leq.
      eassumption.
      eapply IHB. eassumption.
    + edestruct update_live_fun_false.
      eassumption. destructAll.
      eapply IHB. eassumption.
  - inv Hl. reflexivity.
Qed.

Lemma live_size L L' B :
  live B L false = (L', true) ->
  map_size L < map_size L'.
Proof.
  assert (Heq : false = false) by reflexivity. revert Heq. generalize false at 1 3.
  revert L L'; induction B; simpl; intros L L' d Heq Hl; subst.
  - destruct (update_live_fun L v l (live_expr L e PS.empty)) as [L'' b] eqn:Heq.

    destruct b; simpl in *.
    + eapply lt_le_trans.
      eapply update_live_fun_size. eassumption.
      eapply live_size_leq.
      eassumption.
    + edestruct update_live_fun_false.
      eassumption. destructAll.
      eapply IHB. reflexivity. eassumption.
  - inv Hl.
Qed.

Lemma find_live_helper_size B L n L' :
  no_fun_defs B ->
  find_live_helper B L n = Ret L' ->
  (* either a fixpoint is reached *)
  live_map_sound B L' \/
  (* or the distance between L and L' is at least n *)
  map_size L + n <= map_size L'.
Proof.
  revert B L L'. induction n; intros.
  - inv H0. right. lia.
  - simpl in H0.
    destruct (live B L false) as [L1 diff]  eqn:Hlive.

    destruct diff.

    + eapply IHn in H0; eauto. inv H0. now left.
      right.

      eapply live_size in Hlive. lia.

    + inv H0. eapply live_correct in Hlive; eauto.
      destructAll. now left.
Qed.

(* Lemmas about max_size *)

Lemma bitsize_leq bs :
  bitsize bs <= Datatypes.length bs.
Proof.
  induction bs; simpl; eauto. destruct a; lia.
Qed.

Lemma max_map_size_leq L :
  map_size L <= max_map_size L.
Proof.
  unfold map_size, max_map_size.
  eapply List_util.fold_left_monotonic; eauto.
  intros. destruct x2. simpl.
  assert (Hleq := bitsize_leq l).
  lia.
Qed.

Lemma max_map_size_empty :
  max_map_size (M.empty (list bool)) = 0.
Proof. reflexivity. Qed.

(* Proofs that max_max_size is preserved during liveness analysis *)

Lemma set_fun_vars_max_size L f l bs :
  L ! f = Some l ->
  length l = length bs ->
  max_map_size (set_fun_vars L f bs) = max_map_size L.
Proof.
  intros Heq Hlen. unfold set_fun_vars.

  unfold map_size, max_map_size.
  edestruct elements_set_some. eassumption.
  destructAll.
  rewrite H, H0.
  rewrite !fold_left_app. simpl.

  rewrite <- (plus_O_n (fold_left _ _ _ + length bs)).
  rewrite <- (plus_O_n (fold_left _ _ _  + length l)).
  erewrite !List_util.fold_left_acc_plus. simpl. congruence.

  intros ? ? [? ? ]. lia.
  intros ? ? [? ? ]. lia.
Qed.

Lemma update_live_fun_max_size L L' b f xs S :
  update_live_fun L f xs S = (L', b) ->
  max_map_size L' = max_map_size L.
Proof.
  intros Hl.
  unfold update_live_fun in Hl.
  destruct (get_fun_vars L f) eqn:Hf; try congruence.
  unfold get_fun_vars in *.
  destruct (update_bs S xs l) as [bs diff] eqn:Hupd.
  destruct diff.

  - inv Hl.  eapply update_bs_length in Hupd.
    assert (Hupd' := Hupd).
    eapply set_fun_vars_max_size. eassumption. eassumption.

  - inv Hl. reflexivity.
Qed.

Lemma live_max_size L L' d d' B :
  live B L d = (L', d') ->
  max_map_size L' = max_map_size L.
Proof.
  revert L L' d d'; induction B; simpl; intros L L' d d' Hl; subst.
  - destruct (update_live_fun L v l (live_expr L e PS.empty)) as [L'' b] eqn:Heq.

    eapply IHB in Hl. eapply update_live_fun_max_size in Heq. congruence.
  - inv Hl. reflexivity.
Qed.

Lemma find_live_helper_max_size B L n L' :
  no_fun_defs B ->
  find_live_helper B L n = Ret L' ->
  max_map_size L' = max_map_size L.
Proof.
  revert B L L'. induction n; intros.
  - inv H0. reflexivity.
  - simpl in H0.
    destruct (live B L false) as [L1 diff]  eqn:Hlive.

    destruct diff.

    + eapply IHn in H0; eauto. eapply live_max_size in Hlive.
      congruence.

    + inv H0.
      eapply live_max_size in Hlive. lia.
Qed.

Lemma set_fun_vars_max_size_None L f bs :
  L ! f = None ->
  max_map_size (set_fun_vars L f bs) = max_map_size L + length bs.
Proof.
  intros Heq. unfold set_fun_vars.

  unfold map_size, max_map_size.
  edestruct elements_set_none. eassumption.
  destructAll.
  rewrite H, H0.
  rewrite !fold_left_app. simpl.

  rewrite <- (plus_O_n (fold_left _ _ _ + length bs)).
  rewrite <- (plus_O_n (fold_left _ x 0)).
  erewrite !List_util.fold_left_acc_plus. simpl. lia.
  intros ? ? [? ? ]. lia.
  intros ? ? [? ? ]. lia.
Qed.

Lemma get_bool_false_length {A} (l : list A) :
  length (get_bool_false l) = length l.
Proof.
  induction l; simpl; eauto.
Qed.

Lemma get_bool_true_length {A} (l : list A) :
  length (get_bool_true l) = length l.
Proof.
  induction l; simpl; eauto.
Qed.

Lemma num_vars_acc B m n :
  num_vars B (n + m) = num_vars B n + m.
Proof.
  revert m n. induction B; intros; simpl; eauto.

  rewrite <- plus_assoc. rewrite (plus_comm m). rewrite plus_assoc.
  rewrite IHB. lia.
Qed.

Lemma init_live_fun_aux_max_size L B L' m :
  Disjoint _ (Dom_map L) (name_in_fundefs B) ->
  unique_functions B ->
  init_live_fun_aux L B = L' ->
  max_map_size L' + m = max_map_size L + num_vars B m.
Proof.
  revert L L' m; induction B; simpl; intros L L' m Hdis Hun Hinit.
  - eapply IHB in Hinit.
    + rewrite Hinit. rewrite set_fun_vars_max_size_None.
      rewrite get_bool_false_length, num_vars_acc. lia.

      destruct (L ! v) eqn:Heq; eauto. exfalso. eapply Hdis.
      constructor; eauto. eexists; eauto.

    + unfold set_fun_vars.
      rewrite Dom_map_set. inv Hun. sets.

    + inv Hun. sets.

  - congruence.
Qed.

Lemma init_live_fun_max_size L B :
  unique_functions B ->
  init_live_fun B = L ->
  max_map_size L = num_vars B 0.
Proof.
  intros.
  eapply init_live_fun_aux_max_size in H0; eauto.
  rewrite max_map_size_empty in H0. simpl in H0. rewrite <- H0. lia.

  rewrite Dom_map_empty. sets.
Qed.

Lemma remove_escaping_max_size L x :
  max_map_size (remove_escaping L x) <= max_map_size L.
Proof.
  unfold remove_escaping. destruct (get_fun_vars L x) eqn:Hget; subst; eauto.

  unfold max_map_size.
  edestruct cps.M.elements_remove. eassumption.
  destructAll. rewrite H, H0.
  rewrite !fold_left_app. simpl.

  rewrite <- (plus_O_n (fold_left _ x0 0)).
  erewrite !List_util.fold_left_acc_plus. simpl. lia.
  intros ? ? [? ? ]. lia.
  intros ? ? [? ? ]. lia.
  intros ? ? [? ? ]. lia.
Qed.

Lemma remove_escapings_max_size L x :
  max_map_size (remove_escapings L x) <= max_map_size L.
Proof.
  revert L; induction x; simpl; intros L; subst; eauto.
  specialize (IHx (remove_escaping L a)).
  assert (Hleq := remove_escaping_max_size L a). lia.
Qed.

Lemma escaping_fun_fundefs_max_size_mut :
  (forall e L,
      max_map_size (escaping_fun_exp e L) <= max_map_size L) /\
  (forall B L,
      max_map_size (escaping_fun_fundefs B L) <= max_map_size L).
Proof.
  exp_defs_induction IHe IHl IHB; simpl; intros; subst; eauto;
    try (now eapply le_trans; [ eapply IHe | eapply remove_escapings_max_size ]);
    try (now eapply le_trans; [ eapply IHe | eapply remove_escaping_max_size ]).
  - simpl in IHl.
    eapply le_trans. eapply IHl. eapply IHe.
  - simpl in *.
    eapply le_trans. eapply IHe. eapply IHB.
  - eapply remove_escapings_max_size.
  - eapply remove_escaping_max_size.
  - simpl in *.
    eapply le_trans. eapply IHB. eapply IHe.
Qed.

Lemma escaping_fun_exp_max_size :
  (forall e L,
      max_map_size (escaping_fun_exp e L) <= max_map_size L).
Proof. eapply escaping_fun_fundefs_max_size_mut. Qed.

Lemma escaping_fun_fundefs_max_size :
  (forall B L,
      max_map_size (escaping_fun_fundefs B L) <= max_map_size L).
Proof. eapply escaping_fun_fundefs_max_size_mut. Qed.

Lemma find_live_sound (B : fundefs) (e : exp) L :
  no_fun_defs B -> (* no nested fundefs *)
  unique_functions B -> (* unique bindings *)
  find_live (Efun B e) = Ret L ->
  live_map_sound B L.
Proof.
  intros Hnf Hun Hl. unfold find_live in *.
  assert (Hl' := Hl).

  eapply find_live_helper_size in Hl; eauto.
  inv Hl; eauto.
  eapply find_live_helper_max_size in Hl'; eauto.

  assert (Hleq1 := escaping_fun_fundefs_max_size B (init_live_fun B)).
  assert (Hleq2 := escaping_fun_exp_max_size e (escaping_fun_fundefs B (init_live_fun B))).

  erewrite init_live_fun_max_size  with (L := init_live_fun _) in *; eauto.

  assert (Hleq := max_map_size_leq L). lia.
Qed.

(* Domain of live_fun is preserved *)

Lemma update_live_fun_dom L L' f xs S d :
  update_live_fun L f xs S = (L', d) ->
  Dom_map L <--> Dom_map L'.
Proof.
  intros Hl.
  unfold update_live_fun in Hl.
  destruct (get_fun_vars L f) eqn:Hf; try congruence.
  unfold get_fun_vars in *.
  destruct (update_bs S xs l) as [bs diff] eqn:Hupd.
  destruct diff.

  - inv Hl. unfold set_fun_vars.
    rewrite Dom_map_set. rewrite (Union_Same_set [set f] (Dom_map L)). reflexivity.
    eapply Singleton_Included. eexists; eauto.

  - inv Hl. reflexivity.
  - inv Hl. reflexivity.
Qed.

Lemma live_dom L L' d d' B :
  live B L d = (L', d') ->
  Dom_map L <--> Dom_map L'.
Proof.
  revert L L' d d'; induction B; simpl; intros L L' d d' Hl; subst.
  - destruct (update_live_fun L v l (live_expr L e PS.empty)) as [L'' b] eqn:Heq.
    destruct b; simpl in *.
    + eapply IHB in Hl. rewrite <- Hl.
      eapply update_live_fun_dom. eassumption.
    + edestruct update_live_fun_false.
      eassumption. destructAll.
      eapply IHB. eassumption.
  - inv Hl. reflexivity.
Qed.

Lemma find_live_helper_dom B L n L' :
  find_live_helper B L n = Ret L' ->
  Dom_map L <--> Dom_map L'.
Proof.
  revert B L L'. induction n; intros.
  - inv H. reflexivity.
  - simpl in H.
    destruct (live B L false) as [L1 diff] eqn:Hlive.

    destruct diff.

    + eapply live_dom in Hlive.
      rewrite Hlive. eauto.

    + inv H.
      eapply live_dom. eassumption.
Qed.

Lemma init_live_fun_aux_dom L B L' :
  init_live_fun_aux L B = L' ->
  Dom_map L' \subset name_in_fundefs B :|: Dom_map L.
Proof.
  revert L L'; induction B; simpl; intros L L' Hinit.
  - rewrite IHB; eauto.
    unfold set_fun_vars.
    rewrite Dom_map_set. sets.
  - subst. sets.
Qed.

Inductive Known_exp (S : Ensemble var) : exp -> Prop :=
| Known_Constr :
    forall (x : var) (ys : list var) (ct : ctor_tag) (e : exp),
      Disjoint _ (FromList ys) S ->
      Known_exp S e ->
      Known_exp S (Econstr x ct ys e)
| Known_Prim_val :
  forall (x : var) p (e : exp),
    Known_exp S e ->
    Known_exp S (Eprim_val x p e)
| Known_Prim :
  forall (x : var) (g : prim) (ys : list var) (e : exp),
    Disjoint _ (FromList ys) S ->
    Known_exp S e ->
    Known_exp S (Eprim x g ys e)
| Known_Proj :
    forall (x : var) (ct : ctor_tag) (n : N) (y : var) (e : exp),
      ~ y \in S ->
     Known_exp S e ->
     Known_exp S (Eproj x ct n y e)
| Known_Case:
    forall (x : var) (ce : list (ctor_tag * exp)),
      Forall (fun p => Known_exp S (snd p)) ce ->
      Known_exp S (Ecase x ce)
| Known_Fun:
    forall B e,
      Known_fundefs S B ->
      Known_exp S e ->
      Known_exp S (Efun B e)
| Known_Halt :
    forall (x : var),
      ~ x \in S ->
      Known_exp S (Ehalt x)
| Known_App :
    forall (f : var) (ys : list var) (ft : fun_tag),
      Disjoint _ (FromList ys) S ->
      Known_exp S (Eapp f ft ys)
| Known_LetApp :
    forall (x f : var) (ys : list var) (ft : fun_tag) (e : exp),
      Disjoint _ (FromList ys) S ->
      Known_exp S e ->
      Known_exp S (Eletapp x f ft ys e)
with Known_fundefs (S : Ensemble var) : fundefs -> Prop :=
| Known_Fcons :
    forall f ft xs e B,
      Known_exp S e ->
      Known_fundefs S B ->
      Known_fundefs S (Fcons f ft xs e B)
| Known_Fnil :
    Known_fundefs S Fnil.

(* Dom subset *)

Lemma remove_escaping_subset L x :
  Dom_map (remove_escaping L x) \subset Dom_map L.
Proof.
  unfold remove_escaping. destruct (get_fun_vars L x) eqn:Hget; subst; sets.
  rewrite Dom_map_remove. sets.
Qed.

Lemma remove_escapings_subset L x :
  Dom_map (remove_escapings L x) \subset Dom_map L.
Proof.
  revert L; induction x; simpl; intros L; subst; sets.
  eapply Included_trans. eapply IHx. eapply remove_escaping_subset.
Qed.

Lemma escaping_fun_subset_mut :
  (forall e L,
      (Dom_map  (escaping_fun_exp e L)) \subset Dom_map L) /\
  (forall B L,
      (Dom_map (escaping_fun_fundefs B L)) \subset Dom_map L).
Proof.
  exp_defs_induction IHe IHl IHB; simpl; intros; subst; eauto; sets;
  try now (eapply Included_trans; [ eapply IHe | ];
           eauto using remove_escaping_subset, remove_escapings_subset).
  - simpl in *. eapply Included_trans. eapply IHl. eapply IHe.
  - eapply remove_escapings_subset.
  - eapply remove_escaping_subset.
  - eapply Included_trans. eapply IHB. eapply IHe.
Qed.

Lemma escaping_fun_exp_subset :
  (forall e L,
      (Dom_map  (escaping_fun_exp e L)) \subset Dom_map L).
Proof. eapply escaping_fun_subset_mut. Qed.

Lemma escaping_fun_fundefs_subset :
  (forall e L,
      (Dom_map (escaping_fun_fundefs e L)) \subset Dom_map L).
Proof. eapply escaping_fun_subset_mut. Qed.

Lemma remove_escaping_preserves_disjoint S L x :
  Disjoint _ S (Dom_map L) ->
  Disjoint _ S (Dom_map (remove_escaping L x)).
Proof.
  intros Hc. eapply Disjoint_Included_r. eapply remove_escaping_subset. sets.
Qed.

Lemma remove_escapings_preserves_disjoint S L x :
  Disjoint _ S (Dom_map L) ->
  Disjoint _ S (Dom_map (remove_escapings L x)).
Proof.
  intros Hc. eapply Disjoint_Included_r. eapply remove_escapings_subset. sets.
Qed.

Lemma escaping_fun_exp_preserves_disjoint :
  forall e S L,
    Disjoint _ S (Dom_map L) ->
    Disjoint _ S (Dom_map  (escaping_fun_exp e L)).
Proof.
  intros. eapply Disjoint_Included_r. eapply escaping_fun_exp_subset. sets.
Qed.

Lemma escaping_fun_fundefs_preserves_disjoint :
  forall B S L,
    Disjoint _ S (Dom_map L) ->
    Disjoint _ S (Dom_map  (escaping_fun_fundefs B L)).
Proof.
  intros. eapply Disjoint_Included_r. eapply escaping_fun_fundefs_subset. sets.
Qed.

Lemma Known_exp_monotonic_mut :
  (forall e S1 S2,
      Known_exp S1 e ->
      S2 \subset S1 ->
      Known_exp S2 e) /\
  (forall B S1 S2,
      Known_fundefs S1 B ->
      S2 \subset S1 ->
      Known_fundefs S2 B).
Proof.
  exp_defs_induction IHe IHl IHB; simpl; intros; subst; inv H; eauto; try (now econstructor; eauto; sets).
  - inv H2. econstructor. econstructor.
    now eauto.
    assert (Hk : Known_exp S1 (Ecase v l)) by (econstructor; eassumption).
    eapply IHl in Hk; eauto. inv Hk. eassumption.
Qed.

Corollary Known_exp_monotonic :
  forall e S1 S2,
    Known_exp S1 e ->
    S2 \subset S1 ->
    Known_exp S2 e.
Proof. eapply Known_exp_monotonic_mut. Qed.

Corollary Known_fundefs_monotonic :
  forall B S1 S2,
    Known_fundefs S1 B ->
    S2 \subset S1 ->
    Known_fundefs S2 B.
Proof. eapply Known_exp_monotonic_mut. Qed.

Lemma remove_escaping_disjoint L x :
  ~ x \in (Dom_map (remove_escaping L x)).
Proof.
  unfold remove_escaping. destruct (get_fun_vars L x) eqn:Hget; subst; eauto.
  rewrite Dom_map_remove. intros Hc. inv Hc. now eauto.
  intros Hc. inv Hc. unfold get_fun_vars in *. congruence.
Qed.

Lemma remove_escapings_disjoint L x :
  Disjoint _ (FromList x) (Dom_map (remove_escapings L x)).
Proof.
  revert L; induction x; simpl; intros L; subst; eauto.
  - normalize_sets. now sets.
  - normalize_sets. assert (H := remove_escaping_disjoint L a).
    specialize (IHx (remove_escaping L a)).
    eapply Union_Disjoint_l; eauto.
    eapply remove_escapings_preserves_disjoint. eapply Disjoint_Singleton_l. eassumption.
 Qed.

Lemma escaping_fun_fundefs_sound :
  (forall e L,
      Known_exp (Dom_map (escaping_fun_exp e L)) e) /\
  (forall B L,
      Known_fundefs (Dom_map (escaping_fun_fundefs B L)) B).
Proof.
  exp_defs_induction IHe IHl IHB; simpl; intros; subst; eauto;
    try (now econstructor; eauto; eapply escaping_fun_exp_preserves_disjoint; eapply remove_escapings_disjoint).
  - econstructor. econstructor.
    + simpl.
      eapply Known_exp_monotonic. eapply IHe.
      assert (Hsub := escaping_fun_exp_subset (Ecase v l) (escaping_fun_exp e L)). eassumption.
    + simpl in *.
      specialize (IHl (escaping_fun_exp e L)). inv IHl. eassumption.
  - econstructor; eauto.
    assert (Hdis : Disjoint _ [set v0] (Dom_map (escaping_fun_exp e (remove_escaping L v0)))).
    { eapply escaping_fun_exp_preserves_disjoint. eapply Disjoint_Singleton_l.
      eapply remove_escaping_disjoint. }
    intros Hc. eapply Hdis; eauto.
  - econstructor; eauto.
    eapply Known_fundefs_monotonic. eapply IHB.
    eapply escaping_fun_exp_subset.
  - econstructor. eapply remove_escapings_disjoint.
  - econstructor. eapply remove_escaping_disjoint.
  - econstructor; eauto.
    eapply Known_exp_monotonic. eapply IHe.
    eapply escaping_fun_fundefs_subset.
Qed.

Lemma find_live_fun_map_dom B e L :
  find_live (Efun B e) = Ret L ->
  Dom_map L \subset name_in_fundefs B /\
  Known_exp (Dom_map L) (Efun B e).
Proof.
  intros Hf. unfold find_live in *.
  eapply find_live_helper_dom in Hf.
  rewrite <- !Hf at 1. split.

  - eapply Included_trans. eapply escaping_fun_exp_subset.
    eapply Included_trans. eapply escaping_fun_fundefs_subset.
    eapply Included_trans. eapply init_live_fun_aux_dom. reflexivity.
    rewrite Dom_map_empty. sets.

  - eapply Known_exp_monotonic; [| eapply Hf ].
    destruct escaping_fun_fundefs_sound.

    econstructor.

    + eapply Known_fundefs_monotonic. eapply H0.
      eapply Included_trans. eapply escaping_fun_exp_subset. reflexivity.

    + eapply H.
Qed.

(* Top-level theorem for liveness analysis *)
Corollary find_live_sound_top (B : fundefs) (e : exp) L :
  no_fun_defs B -> (* no nested fundefs *)
  unique_functions B -> (* unique bindings *)
  find_live (Efun B e) = Ret L ->
  live_map_sound B L /\
  Dom_map L \subset name_in_fundefs B /\
  Known_exp (Dom_map L) (Efun B e).
Proof.
  intros Hnf Hun Hl.
  edestruct find_live_fun_map_dom. eassumption.
  split; eauto. eapply find_live_sound; eassumption.
Qed.

(* is_hoisted is correct *)

Lemma is_hoisted_exp_correct e :
  is_hoisted_exp e = true ->
  no_fun e.
Proof.
  induction e using exp_ind'; simpl; intros; eauto.
  - simpl in *.
    eapply andb_prop in H. destructAll.
    econstructor; eauto.
  - congruence.
Qed.

Lemma is_hoisted_fundefs_correct B :
  is_hoisted_fundefs B = true ->
  no_fun_defs B.
Proof.
  induction B; simpl; intros; eauto.

  eapply andb_prop in H. destructAll.
  econstructor; eauto.
  eapply is_hoisted_exp_correct; eauto.
Qed.

Lemma is_hoisted_correct B e :
  is_hoisted (Efun B e) = true ->
  no_fun_defs B /\ no_fun e.
Proof.
  intros H. simpl in *.  eapply andb_prop in H.
  destructAll.
  split; eauto using is_hoisted_exp_correct, is_hoisted_fundefs_correct.
Qed.