(* DONE        Change .cry so it uses + and (-)
   DONE (?)    Figure out numbers for Plus, Eq, Neg
   PARTIAL     Use tactics to finish proofs
   DONE        Write Fib in coq (using 32 bit nats from compcert library)
   PARTIAL     Prove equivalence of Fib implementations
*)

Require Import List.
Import ListNotations.

(* Borrow from CompCert *)
Require Import Coqlib.

Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import Values.
Require Import BuiltinSanity.
Require Import EvalTac.

(* right side of this generated from cryptol implementation *)

Import HaskellListNotations.

Definition fib_cry := [(NonRecursive (Decl (242,"demote") DPrim)),(NonRecursive (Decl (243,"+") DPrim)),(NonRecursive (Decl (244,"-") DPrim)),(NonRecursive (Decl (245,"*") DPrim)),(NonRecursive (Decl (246,"/") DPrim)),(NonRecursive (Decl (247,"%") DPrim)),(NonRecursive (Decl (248,"^^") DPrim)),(NonRecursive (Decl (249,"lg2") DPrim)),(NonRecursive (Decl (251,"True") DPrim)),(NonRecursive (Decl (252,"False") DPrim)),(NonRecursive (Decl (253,"negate") DPrim)),(NonRecursive (Decl (254,"complement") DPrim)),(NonRecursive (Decl (255,"<") DPrim)),(NonRecursive (Decl (256,">") DPrim)),(NonRecursive (Decl (257,"<=") DPrim)),(NonRecursive (Decl (258,">=") DPrim)),(NonRecursive (Decl (259,"==") DPrim)),(NonRecursive (Decl (260,"!=") DPrim)),(NonRecursive (Decl (261,"===") (DExpr (ETAbs (329,"a") (ETAbs (330,"b") (EAbs (331,"f") (EAbs (332,"g") (EAbs (333,"x") (EApp (EApp (ETApp (EVar (259,"==")) (TVar (TVBound 31 KType))) (EApp (EVar (331,"f")) (EVar (333,"x")))) (EApp (EVar (332,"g")) (EVar (333,"x")))))))))))),(NonRecursive (Decl (262,"!==") (DExpr (ETAbs (334,"a") (ETAbs (335,"b") (EAbs (336,"f") (EAbs (337,"g") (EAbs (338,"x") (EApp (EApp (ETApp (EVar (260,"!=")) (TVar (TVBound 41 KType))) (EApp (EVar (336,"f")) (EVar (338,"x")))) (EApp (EVar (337,"g")) (EVar (338,"x")))))))))))),(NonRecursive (Decl (263,"min") (DExpr (ETAbs (339,"a") (EAbs (340,"x") (EAbs (341,"y") (EIf (EApp (EApp (ETApp (EVar (255,"<")) (TVar (TVBound 50 KType))) (EVar (340,"x"))) (EVar (341,"y"))) (EVar (340,"x")) (EVar (341,"y"))))))))),(NonRecursive (Decl (264,"max") (DExpr (ETAbs (342,"a") (EAbs (343,"x") (EAbs (344,"y") (EIf (EApp (EApp (ETApp (EVar (256,">")) (TVar (TVBound 56 KType))) (EVar (343,"x"))) (EVar (344,"y"))) (EVar (343,"x")) (EVar (344,"y"))))))))),(NonRecursive (Decl (265,"/\\") (DExpr (EAbs (345,"x") (EAbs (346,"y") (EIf (EVar (345,"x")) (EVar (346,"y")) (EVar (252,"False")))))))),(NonRecursive (Decl (266,"\\/") (DExpr (EAbs (347,"x") (EAbs (348,"y") (EIf (EVar (347,"x")) (EVar (251,"True")) (EVar (348,"y")))))))),(NonRecursive (Decl (267,"==>") (DExpr (EAbs (349,"a") (EAbs (350,"b") (EIf (EVar (349,"a")) (EVar (350,"b")) (EVar (251,"True")))))))),(NonRecursive (Decl (268,"&&") DPrim)),(NonRecursive (Decl (269,"||") DPrim)),(NonRecursive (Decl (270,"^") DPrim)),(NonRecursive (Decl (271,"zero") DPrim)),(NonRecursive (Decl (272,"<<") DPrim)),(NonRecursive (Decl (273,">>") DPrim)),(NonRecursive (Decl (274,"<<<") DPrim)),(NonRecursive (Decl (275,">>>") DPrim)),(NonRecursive (Decl (276,"#") DPrim)),(NonRecursive (Decl (277,"splitAt") DPrim)),(NonRecursive (Decl (278,"join") DPrim)),(NonRecursive (Decl (279,"split") DPrim)),(NonRecursive (Decl (280,"reverse") DPrim)),(NonRecursive (Decl (281,"transpose") DPrim)),(NonRecursive (Decl (282,"@") DPrim)),(NonRecursive (Decl (283,"@@") DPrim)),(NonRecursive (Decl (284,"!") DPrim)),(NonRecursive (Decl (285,"!!") DPrim)),(NonRecursive (Decl (286,"update") DPrim)),(NonRecursive (Decl (287,"updateEnd") DPrim)),(NonRecursive (Decl (288,"updates") (DExpr (ETAbs (404,"a") (ETAbs (405,"b") (ETAbs (406,"c") (ETAbs (407,"d") (EAbs (408,"xs0") (EAbs (409,"idxs") (EAbs (410,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (284,"!")) (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 124 KNum)])) (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)])) (TCon (TC (TCNum 0)) [])) (EVar (411,"xss"))) (ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) []))) [(Recursive [(Decl (411,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (276,"#")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 124 KNum))) (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)])) (EList [(EVar (408,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (286,"update")) (TVar (TVBound 121 KNum))) (TVar (TVBound 122 KType))) (TVar (TVBound 123 KNum))) (EVar (412,"xs"))) (EVar (413,"i"))) (EVar (414,"b"))) [[(From (412,"xs") (EVar (411,"xss")))],[(From (413,"i") (EVar (409,"idxs")))],[(From (414,"b") (EVar (410,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (289,"updatesEnd") (DExpr (ETAbs (415,"a") (ETAbs (416,"b") (ETAbs (417,"c") (ETAbs (418,"d") (EAbs (419,"xs0") (EAbs (420,"idxs") (EAbs (421,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (284,"!")) (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 159 KNum)])) (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)])) (TCon (TC (TCNum 0)) [])) (EVar (422,"xss"))) (ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) []))) [(Recursive [(Decl (422,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (276,"#")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 159 KNum))) (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)])) (EList [(EVar (419,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (287,"updateEnd")) (TVar (TVBound 156 KNum))) (TVar (TVBound 157 KType))) (TVar (TVBound 158 KNum))) (EVar (423,"xs"))) (EVar (424,"i"))) (EVar (425,"b"))) [[(From (423,"xs") (EVar (422,"xss")))],[(From (424,"i") (EVar (420,"idxs")))],[(From (425,"b") (EVar (421,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (290,"fromThen") DPrim)),(NonRecursive (Decl (291,"fromTo") DPrim)),(NonRecursive (Decl (292,"fromThenTo") DPrim)),(NonRecursive (Decl (293,"infFrom") DPrim)),(NonRecursive (Decl (294,"infFromThen") DPrim)),(NonRecursive (Decl (295,"error") DPrim)),(NonRecursive (Decl (296,"pmult") DPrim)),(NonRecursive (Decl (297,"pdiv") DPrim)),(NonRecursive (Decl (298,"pmod") DPrim)),(NonRecursive (Decl (299,"random") DPrim)),(NonRecursive (Decl (303,"take") (DExpr (ETAbs (451,"front") (ETAbs (452,"back") (ETAbs (453,"elem") (EAbs (454,"__p1") (EWhere (EVar (456,"x")) [(NonRecursive (Decl (455,"__p2") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (277,"splitAt")) (TVar (TVBound 214 KNum))) (TVar (TVBound 215 KNum))) (TVar (TVBound 216 KType))) (EVar (454,"__p1")))))),(NonRecursive (Decl (456,"x") (DExpr (ESel (EVar (455,"__p2")) (TupleSel 0))))),(NonRecursive (Decl (457,"__p0") (DExpr (ESel (EVar (455,"__p2")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (304,"drop") (DExpr (ETAbs (458,"front") (ETAbs (459,"back") (ETAbs (460,"elem") (EAbs (461,"__p4") (EWhere (EVar (464,"y")) [(NonRecursive (Decl (462,"__p5") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (277,"splitAt")) (TVar (TVBound 231 KNum))) (TVar (TVBound 232 KNum))) (TVar (TVBound 233 KType))) (EVar (461,"__p4")))))),(NonRecursive (Decl (463,"__p3") (DExpr (ESel (EVar (462,"__p5")) (TupleSel 0))))),(NonRecursive (Decl (464,"y") (DExpr (ESel (EVar (462,"__p5")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (305,"tail") (DExpr (ETAbs (465,"a") (ETAbs (466,"b") (EAbs (467,"xs") (EApp (ETApp (ETApp (ETApp (EVar (304,"drop")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 249 KNum))) (TVar (TVBound 250 KType))) (EVar (467,"xs"))))))))),(NonRecursive (Decl (306,"width") (DExpr (ETAbs (468,"bits") (ETAbs (469,"len") (ETAbs (470,"elem") (EAbs (471,"__p6") (ETApp (ETApp (EVar (242,"demote")) (TVar (TVBound 256 KNum))) (TVar (TVBound 255 KNum)))))))))),(NonRecursive (Decl (307,"undefined") (DExpr (ETAbs (472,"a") (EApp (ETApp (ETApp (EVar (295,"error")) (TVar (TVBound 260 KType))) (TCon (TC (TCNum 9)) [])) (EList [(ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 117)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 110)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 100)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 101)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 102)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 105)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 110)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 101)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 100)) [])) (TCon (TC (TCNum 8)) []))])))))),(NonRecursive (Decl (308,"groupBy") (DExpr (ETAbs (473,"each") (ETAbs (474,"parts") (ETAbs (475,"elem") (ETApp (ETApp (ETApp (EVar (279,"split")) (TVar (TVBound 266 KNum))) (TVar (TVBound 265 KNum))) (TVar (TVBound 267 KType))))))))),(NonRecursive (Decl (310,"trace") DPrim)),(NonRecursive (Decl (311,"traceVal") (DExpr (ETAbs (480,"n") (ETAbs (481,"a") (EAbs (482,"msg") (EAbs (483,"x") (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (310,"trace")) (TVar (TVBound 273 KNum))) (TVar (TVBound 274 KType))) (TVar (TVBound 274 KType))) (EVar (482,"msg"))) (EVar (483,"x"))) (EVar (483,"x")))))))))),(Recursive [(Decl (484,"fib") (DExpr (EAbs (485,"n") (EIf (EApp (EApp (ETApp (EVar (259,"==")) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EVar (485,"n"))) (ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 32)) []))) (ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 32)) [])) (EIf (EApp (EApp (ETApp (EVar (259,"==")) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EVar (485,"n"))) (ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 32)) []))) (ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 32)) [])) (EApp (EApp (ETApp (EVar (243,"+")) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EApp (EVar (484,"fib")) (EApp (EApp (ETApp (EVar (243,"+")) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EVar (485,"n"))) (EApp (ETApp (EVar (253,"negate")) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 32)) [])))))) (EApp (EVar (484,"fib")) (EApp (EApp (ETApp (EVar (243,"+")) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EVar (485,"n"))) (EApp (ETApp (EVar (253,"negate")) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (ETApp (ETApp (EVar (242,"demote")) (TCon (TC (TCNum 2)) [])) (TCon (TC (TCNum 32)) [])))))))))))])].

Definition width : nat := 32.
Definition fibident : ident := (484, "fib").
Definition fibvar : ident := (12, "var").

(* Lemma nz : width <> O. *)
(* Proof.  *)
(*   unfold width. congruence.  *)
(* Qed. *)

(* Global environment *)
Definition fib_ge := bind_decl_groups fib_cry gempty.

Definition nz32 (n:Z) := bits (@repr width n).
Definition Env (n:Z) := extend empty fibvar (nz32 n).

Definition E := Env 0.

(* Fib 0 = 1 *)
Lemma eval_fib0 : eval_expr fib_ge E (EApp (EVar fibident) (EVar fibvar)) (nz32 1).
Proof.
  e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e.
  e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e. e.
  (* lol *)
Qed.

Definition E1 := Env 1.

(* Fib 1 = 1 *)
Lemma eval_fib1 : eval_expr fib_ge E1 (EApp (EVar fibident) (EVar fibvar)) (nz32 1).
Proof.
  repeat e.

Qed.

Definition E3 := Env 3.

(* Fib 3 = 3 *)
Lemma eval_fib3 : eval_expr fib_ge E3 (EApp (EVar fibident) (EVar fibvar)) (nz32 3).
Proof.
  repeat e. (* Takes like 10 min *)

Qed.

(*  Old version before Semantics.v changes

(* Grab some useful tactics :
  e: applies econstructor and some simplification whenever there is no choice to be made (not an If or Var)
  global: resolves the constructor for a var in the global env
  local: resolves the constructor for a var in the local env  *)

(* right side of this generated from cryptol implementation Fib.cry *)

Definition fib_cry : DeclGroup := (Recursive [(Decl 484 (DExpr (EAbs 485 (EIf (EApp (EApp (ETApp (EVar 259) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EVar 485)) (ETApp (ETApp (EVar 242) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 32)) []))) (ETApp (ETApp (EVar 242) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 32)) [])) (EIf (EApp (EApp (ETApp (EVar 259) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EVar 485)) (ETApp (ETApp (EVar 242) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 32)) []))) (ETApp (ETApp (EVar 242) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 32)) [])) (EApp (EApp (ETApp (EVar 243) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EApp (EVar 484) (EApp (EApp (ETApp (EVar 243) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EVar 485)) (EApp (ETApp (EVar 253) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (ETApp (ETApp (EVar 242) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 32)) [])))))) (EApp (EVar 484) (EApp (EApp (ETApp (EVar 243) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (EVar 485)) (EApp (ETApp (EVar 253) (TCon (TC TCSeq) [TCon (TC (TCNum 32)) [],TCon (TC TCBit) []])) (ETApp (ETApp (EVar 242) (TCon (TC (TCNum 2)) [])) (TCon (TC (TCNum 32)) [])))))))))))]).

Definition width : nat := 32.
Definition fibnum : ident := 484.
Definition fibvar : ident := 12.

(* A non-zero width *)
Lemma nz : width <> O.
Proof.
  unfold width. congruence.
Qed.

(* 242 -> plus *)
(* 259 -> eq *)
(* 243 -> neg *)
Definition plus_decl := builtin_binop 242 Plus.
Definition eq_decl := builtin_binop 259 Eq.
Definition neg_decl := builtin_unop 243 Neg.

(* Global environment *)
Definition fib_ge := bind_decl_group fib_cry
                                    (bind_decl_group neg_decl
                                    (bind_decl_group eq_decl
                                    (bind_decl_group plus_decl
                                                     gempty))).

(* Local environment *)
Definition Env (n:Z) := extend empty fibvar (bits (@repr width nz n)).

Definition E := Env 0.

(* Fib 0 = 1 *)
Lemma eval_fib0 : eval_expr fib_ge E (EApp (EVar fibnum) (EVar fibvar)) (bits (@repr width nz 1)).
Proof.
  e.
  - global. e.
  - local.
  - eapply eval_if_t.
    + e. e. e. global. e. local.
      * unfold extend. e.
      * e.
      * e.
        -- local.
        -- local.
        -- econstructor. exact nz. exact nz. reflexivity.
    + e.
  Unshelve. exact nz.
Qed.

Definition E1 := Env 1.

(* Fib 1 = 1 *)
Lemma eval_fib1 : eval_expr fib_ge E1 (EApp (EVar fibnum) (EVar fibvar)) (bits (@repr width nz 1)).
Proof.
  e.
  - global. e.
  - local.
  - eapply eval_if_f.                 (* Doesn't match first base case *)
    + e. e. e. global. e. local.
      * unfold extend. e.
      * e.
      * e.
        -- local.
        -- local.
        -- econstructor; try exact nz. reflexivity.
    + eapply eval_if_t.               (* Matches second base case *)
      * e. e. e. global. e. local.
        -- unfold extend. e.
        -- e.
        -- e.
           ++ local.
           ++ local.
           ++ econstructor; try exact nz. reflexivity.
      * e.
  Unshelve. all: exact nz.
Qed.

Definition E2 := Env 2.

Lemma plus_fib12s : (eval_expr fib_ge E2 (EApp (EVar 242) (EApp (EVar fibvar) (EVar fibvar))) (bits (@repr width nz 24))).
Proof.
  e.
  - global. e.
  - e.
    + eapply eval_global_var. unfold E2. unfold Env. unfold extend. simpl.
Admitted.

(*Lemma plus_f0_f1 : eval_expr fib_ge E2 (EApp (EVar 242) (eval_expr fib_ge E (EApp (EVar fibnum) (EVar fibvar))) (eval_expr fib_ge E1 (EApp (EVar fibnum) (EVar fibvar)))) (bits (@repr width nz 0)).
*)

(* Fib 2 = 2 *)
Lemma eval_fib2 : eval_expr fib_ge E2 (EApp (EVar fibnum) (EVar fibvar)) (bits (@repr width nz 2)).
Proof.
  e.
  - global. e.
  - local.
  - eapply eval_if_f.                  (* Doesn't match first base case *)
    + e. e. e. global. e. local.
      * unfold extend. e.
      * e.
      * e.
        -- local.
        -- local.
        -- econstructor; try exact nz. reflexivity.
    + eapply eval_if_f.                (* Doesn't match second base case *)
      * e. e. e. global. e. local.
        -- unfold extend. e.
        -- e.
        -- e.
          ++ local.
          ++ local.
          ++ econstructor; try exact nz. reflexivity.
      * econstructor.                  (* Take recursive case *)
      (* Something is going wrong in the next line *)
      e. e. e. global. e. e. global. e. e. e. e. global. e. local. e. local.
        -- (* This isn't true - eapply eval_neg.*)
Admitted.

Definition E3 := Env 3.

(* Fib 3 = 3 *)
Lemma eval_fib3 : eval_expr fib_ge E3 (EApp (EVar fibnum) (EVar fibvar)) (bits (@repr width nz 3)).
Proof.
  econstructor.
  - unfold fib_ge. simpl. eapply eval_global_var.
    + unfold E. unfold extend. simpl. unfold empty. reflexivity.
    + simpl. reflexivity.
    + econstructor.
  - econstructor. unfold E. unfold extend. simpl. reflexivity.
  - eapply eval_if_f. e. e. e. global. e. local. local. local. e. local. local.
    + econstructor; try exact nz. reflexivity.
    + eapply eval_if_f. e. e. e. global. e. local. local. local. e. local. local.
      * econstructor; try exact nz. reflexivity.
      * (* Getting closer. This econstructor is maybe not right*)
    econstructor. e. e. e. global. e. e. global. local. e.  e. e. global. local. local. e. local.
Admitted.

(*
 (* #3 *)unfold fib_ge. simpl.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    + unfold extend. simpl.

 (* #3 *)eapply eval_if_t.
    + econstructor.
      econstructor.
      econstructor.
      econstructor. unfold extend. simpl. unfold E. unfold extend. simpl. unfold empty.

 (* #3 *)unfold fib_ge. simpl. econstructor. econstructor. econstructor. econstructor. eapply eval_global_var.
    unfold extend. simpl. unfold E. unfold extend. simpl. unfold empty. reflexivity.

 (* #3 *) econstructor.
    + econstructor.
      econstructor.
      econstructor.
      * econstructor. unfold extend. simpl. unfold E.
        unfold extend. simpl. unfold empty. (* This isn't true. So E doesn't have everything we need (?) *)

*)

*)


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Import securite.

Lemma POinvprel2 :
 forall (l l0 : list C) (k k0 k1 k2 : K) (c c0 c1 c2 : C)
   (d d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19
    d20 : D),
 inv0
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 inv1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 invP
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 rel2
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l)
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0) ->
 invP
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0).

Proof.
do 32 intro.
unfold rel2 in |- *. intros Inv0 Inv1 InvP and1.
elim and1; intros t1 and2; elim and2; intros t2 and3; elim and3;
 intros t3 and4; elim and4; intros eq_l0 t4.
elim eq_l0; assumption.
Qed.


Require Import Common.Definitions.
Require Import Common.Util.
Require Export Common.Values.
Require Export Common.Linking.
Require Import Common.Memory.
Require Import Lib.Monads.
Require Import Lib.Extra.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype.
From extructures Require Import fmap.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Set Bullet Behavior "Strict Subproofs".

(* NOTE: Technically a [Variant], i.e., there is no use for the [Inductive]
   principle in proofs, but it is required to derive a QuickChick generator. *)
Inductive register : Type :=
  R_ONE | R_COM | R_AUX1 | R_AUX2 | R_RA | R_SP | R_ARG.

Definition register_eqb (r1 r2 : register) : bool :=
  match r1, r2 with
  | R_ONE, R_ONE
  | R_COM, R_COM
  | R_AUX1, R_AUX1
  | R_AUX2, R_AUX2
  | R_RA, R_RA
  | R_SP, R_SP
  | R_ARG, R_ARG
    => true
  | _, _
    => false
  end.

Lemma registerP : Equality.axiom register_eqb.
Proof.
  intros [] []; by constructor.
Qed.

Definition register_eqMixin: Equality.mixin_of register := EqMixin registerP.
Canonical register_eqType := Eval hnf in EqType register register_eqMixin.

Definition label := nat.

Variant imvalue : Type :=
| IInt : Z -> imvalue
| IPtr : Pointer.t -> imvalue.

Definition imvalue_eqb (v1 v2 : imvalue) : bool :=
  match v1, v2 with
  | IInt i1, IInt i2 => Z.eqb i1 i2
  | IPtr p1, IPtr p2 => Pointer.eq p1 p2
  | _, _ => false
  end.

Lemma imvalueP : Equality.axiom imvalue_eqb.
Proof.
  intros [] [];
    try (by constructor);
    simpl.
  - destruct (Z.eqb_spec z z0); constructor.
    + subst. reflexivity.
    + injection. contradiction.
  - destruct (Pointer.eqP t t0); constructor.
    + subst. reflexivity.
    + injection. contradiction.
Qed.

Definition imvalue_eqMixin: Equality.mixin_of imvalue := EqMixin imvalueP.
Canonical imvalue_eqType := Eval hnf in EqType imvalue imvalue_eqMixin.

Definition imm_to_val (im : imvalue) : value :=
  match im with
  | IInt n => Int n
  | IPtr p => Ptr p
  end.

Variant instr :=
| INop : instr
| ILabel : label -> instr
(* register operations *)
| IConst : imvalue -> register -> instr
| IMov : register -> register -> instr
| IBinOp : binop -> register -> register -> register -> instr
| IPtrOfLabel : label -> register -> instr
(* memory operations *)
| ILoad : register -> register -> instr
| IStore : register -> register -> instr
| IAlloc : register -> register -> instr
(* conditional and unconditional jumps *)
| IBnz : register -> label -> instr
| IJump : register -> instr
| IJal : label -> instr
| IJumpFunPtr : register -> instr
(* components interaction *)
| ICall : Component.id -> Procedure.id -> instr
| IReturn : instr
(* termination *)
| IHalt : instr.

Definition instr_eqb (i1 i2 : instr) : bool :=
  match i1, i2 with
  | INop, INop
  | IReturn, IReturn
  | IHalt, IHalt
    => true
  | ILabel l1, ILabel l2
  | IJal l1, IJal l2
    => ssrnat.eqn l1 l2
  | ICall C1 P1, ICall C2 P2
    => ssrnat.eqn C1 C2 && ssrnat.eqn P1 P2
  | IJump r1, IJump r2
  | IJumpFunPtr r1, IJumpFunPtr r2
    => register_eqb r1 r2
  | ILoad r1 r1', ILoad r2 r2'
  | IStore r1 r1', IStore r2 r2'
  | IAlloc r1 r1', IAlloc r2 r2'
  | IMov r1 r1', IMov r2 r2'
    => register_eqb r1 r2 && register_eqb r1' r2'
  | IPtrOfLabel l1 r1, IPtrOfLabel l2 r2
  | IBnz r1 l1, IBnz r2 l2
    => ssrnat.eqn l1 l2 && register_eqb r1 r2
  | IConst v1 r1, IConst v2 r2
    => imvalue_eqb v1 v2 && register_eqb r1 r2
  | IBinOp op1 r1 r1' r1'', IBinOp op2 r2 r2' r2''
    => binop_eqb op1 op2 &&
       register_eqb r1 r2 && register_eqb r1' r2' && register_eqb r1'' r2''
  | _, _
    => false
  end.

(* TODO: Is this available anywhere? Move in any case. *)
Lemma eqnP : Equality.axiom ssrnat.eqn.
  intros n.
  induction n as [| n' IHn'].
  - intros [| m']; by constructor.
  - intros [| m'].
    + by constructor.
    + simpl.
      specialize (IHn' m').
      inversion IHn'; subst;
        constructor.
      * reflexivity.
      * injection. contradiction.
Qed.

(* TODO: Complete and reuse tactic above. *)
Ltac t_reflecter :=
  repeat
    (* From the rightto account for the associativity of the conjunction. *)
    (match goal with
     | |- ssrbool.reflect _ (ssrnat.eqn ?N1 ?N2) =>
       destruct (eqnP N1 N2)
     | |- ssrbool.reflect _ (_ && ssrnat.eqn ?N1 ?N2) =>
       destruct (eqnP N1 N2)
     | |- ssrbool.reflect _ (imvalue_eqb ?N1 ?N2) =>
       destruct (imvalueP N1 N2)
     | |- ssrbool.reflect _ (binop_eqb ?OP1 ?OP2) =>
       destruct (binopP OP1 OP2)
     | |- ssrbool.reflect _ (register_eqb ?R1 ?R2) =>
       destruct (registerP R1 R2)
     | |- ssrbool.reflect _ (_ && register_eqb ?R1 ?R2) =>
       destruct (registerP R1 R2)
     end;
     subst;
     (* Rearrange conjuncts so that simplification and recursion work. *)
     try rewrite andb_true_r; try rewrite andb_false_r;
     simpl);
  (* Phase 2: solve appropriate reflection case. *)
  constructor;
  (* True cases are solved by reflexivity... *)
  try reflexivity;
  (* ... and false cases by contradiction on injective constructors. *)
  injection; contradiction.

Lemma instrP : Equality.axiom instr_eqb.
Proof.
  intros [] [];
    try (by constructor);
    simpl;
    t_reflecter.
Qed.

Definition instr_eqMixin: Equality.mixin_of instr := EqMixin instrP.
Canonical instr_eqType := Eval hnf in EqType instr instr_eqMixin.

Definition code := list instr.

Definition code_eqb (c1 c2 : code) : bool :=
  eqseq c1 c2.

Lemma codeP : Equality.axiom code_eqb.
Proof.
  intros c1.
  induction c1 as [| i1 c1' IHc1'];
    intros c2.
  - destruct c2 as [| i2 c2'];
      by constructor.
  - destruct c2 as [| i2 c2'].
    + by constructor.
    + simpl. destruct (i1 == i2) eqn:Hcase.
      * move: Hcase => /eqP ->.
        specialize (IHc1' c2').
        inversion IHc1'; subst;
          constructor.
        -- reflexivity.
        -- injection as ?; subst.
           contradiction.
      * constructor.
        injection as ? ?; subst.
        move: Hcase => /eqP.
        contradiction.
Qed.

Definition code_eqMixin: Equality.mixin_of code := EqMixin codeP.
Canonical code_eqType := Eval hnf in EqType code code_eqMixin.

Module Intermediate.

Module Register.
  Definition t : Type := NMap value.

  Definition to_nat (r : register) : nat :=
    match r with
    | R_ONE  => 0
    | R_COM  => 1
    | R_AUX1 => 2
    | R_AUX2 => 3
    | R_RA   => 4
    | R_SP   => 5
    | R_ARG  => 6
    end.

  Definition init :=
    mkfmap [(to_nat R_ONE, Undef);
            (to_nat R_COM, Int 0);
            (to_nat R_AUX1, Undef);
            (to_nat R_AUX2, Undef);
            (to_nat R_RA, Undef);
            (to_nat R_SP, Undef);
            (to_nat R_ARG, Undef)].

  Definition get (r : register) (regs : t) : value :=
    match getm regs (to_nat r) with
    | Some val => val
    (* this should never happen (i.e. regs should be well-formed) *)
    | None => Undef
    end.

  Definition set (r : register) (val : value) (regs : t) : t :=
    setm regs (to_nat r) val.

  Definition invalidate (regs : t) : t :=
    mkfmap [(to_nat R_ONE, Undef);
            (to_nat R_COM, get R_COM regs);
            (to_nat R_AUX1, Undef);
            (to_nat R_AUX2, Undef);
            (to_nat R_RA, Undef);
            (to_nat R_SP, Undef);
            (to_nat R_ARG, Undef)].

  Lemma invalidate_eq : forall regs1 regs2,
    get R_COM regs1 = get R_COM regs2 ->
    invalidate regs1 = invalidate regs2.
  Proof.
    intros regs1 regs2 Hregs.
    unfold invalidate.
    congruence.
  Qed.

  Definition eqb (r1 r2 : register) : bool :=
    match r1, r2 with
    | R_ONE, R_ONE
    | R_COM, R_COM
    | R_AUX1, R_AUX1
    | R_AUX2, R_AUX2
    | R_RA, R_RA
    | R_SP, R_SP
    | R_ARG, R_ARG => true
    | _, _ => false
    end.

  Lemma eqP : Equality.axiom eqb.
  Proof.
    intros [] []; by constructor.
  Qed.

  Definition eqMixin: Equality.mixin_of register := EqMixin eqP.
  Canonical eqType := Eval hnf in EqType register eqMixin.

  Lemma reg_in_domm_init_Undef r:
    r \in domm init ->
    init r = (if r == to_nat R_COM then Some (Int 0) else Some Undef).
  Proof.
    unfold init. intros regdomm.
    rewrite !domm_set in regdomm.
    simpl in *.
    destruct (r == 1);
    repeat match goal with
    | N : nat |- _ => destruct N as [| N]; first by simpl
    end;
    by rewrite !in_fsetU1 domm0 in regdomm.
  Qed.

  Lemma to_nat_inv r1 r2 :
    to_nat r1 = to_nat r2 ->
    r1 = r2.
  Proof.
    intros Heq.
    destruct r1;
      destruct r2;
      by inversion Heq.
  Qed.

  Lemma gss reg val regs :
    get reg (Register.set reg val regs) = val.
  Proof.
    by rewrite /get /set setmE eqxx.
  Qed.

  Lemma gso reg reg' val regs :
    reg <> reg' ->
    get reg (Register.set reg' val regs) = Register.get reg regs.
  Proof.
    intros Heq.
    assert (Heqb : reg != reg') by (by apply /eqP).
    unfold get, set. rewrite setmE. unfold eq_op. simpl.
    destruct (ssrnat.eqn (to_nat reg) (to_nat reg')) eqn:Hcase.
    - move: Hcase => /ssrnat.eqnP => Hcase.
      apply to_nat_inv in Hcase.
      contradiction.
    - reflexivity.
  Qed.

  Lemma gicom regs :
    get R_COM (invalidate regs) = get R_COM regs.
  Proof. reflexivity. Qed.

  Lemma gio reg regs :
    reg <> R_COM ->
    get reg (invalidate regs) = Undef.
  Proof. now destruct reg. Qed.

  Lemma gi reg regs :
    get reg (invalidate regs) = if eqb reg R_COM then get reg regs else Undef.
  Proof. now destruct reg. Qed.
End Register.

Module EntryPoint.
  Definition t := NMap (seq Block.id).

  Definition get (C: Component.id) (P: Procedure.id) (E: t) : option Block.id :=
    match getm E C with
    | Some addrs => if P \in addrs then Some P else None
    | None => None
    end.

  Lemma get_some C P E b : get C P E = Some b -> C \in domm E.
  Proof.
    unfold get. intros Hget.
    destruct (E C) as [M |] eqn:Hcase; last discriminate.
    apply /dommP. eauto.
  Qed.
End EntryPoint.

(* programs *)

Record program := mkProg {
  prog_interface: Program.interface;
  prog_procedures: NMap (NMap code);
  prog_buffers: NMap (*{fmap Block.id ->*) (nat + list value)(*}*);
  prog_main: bool
}.

(* well-formedness of programs *)

Definition well_formed_instruction
           (p: program) (C: Component.id) (P: Procedure.id) (i: instr) : Prop :=
  match i with
  | IBnz r l =>
    (* the branch refers to a label inside the current procedure C.P *)
    exists Cprocs Pcode,
      getm (prog_procedures p) C = Some Cprocs /\
      getm Cprocs P = Some Pcode /\
      In (ILabel l) Pcode
  | IJal l
  | IPtrOfLabel l _
    =>
    (* the jump refers to a label inside the current component C *)
    exists Cprocs P' P'code,
      getm (prog_procedures p) C = Some Cprocs /\
      getm Cprocs P' = Some P'code /\
      In (ILabel l) P'code
  | ICall C' P' =>
    (* a call is well-formed only if it targets another component and the
       interface is allowing it to happen *)
    C <> C' /\ imported_procedure (prog_interface p) C C' P'
  | IConst (IPtr ptr) r =>
    (* static pointers refer to static buffers *)
    (* [DynShare] NOTE: Pointers can (and need to) be forged as constant
       expressions. The guarantee that these point only to static buffers is
       obtained in tandem with a program semantics that disallows the use of bad
       pointers, and a representation of the program as environment which maps
       static buffers to runtime buffers with exactly the same buffer
       identifiers. At the moment, no symbol substitution/concretization is
       possible, i.e., runtime pointers are exactly those hardcoded in the
       program. *)
    (* [DynShare] Add the restriction that pointers can only be forged to point
       to buffers in the same component. What were the implications of the
       absence of this condition in the existing proof? *)
    Pointer.component ptr = C /\
    Pointer.permission ptr = Permission.data /\
    exists buf,
      getm (prog_buffers p) (Pointer.component ptr) = Some buf
      /\
  (*In (Pointer.block ptr) (map fst bufs)*)
      Pointer.block ptr = Block.local
  (* the other instruction are well-formed by construction *)
  | IConst (IInt i) r => True
  | ILabel l => True
  | INop => True
  | IMov r1 r2 => True
  | IBinOp bop r1 r2 r3 => True
  | ILoad r1 r2 => True
  | IStore r1 r2 => True
  | IAlloc r1 r2 => True
  | IJump r => True
  | IJumpFunPtr r => True
  | IReturn => True
  | IHalt => True
  end.

(* RB: TODO: Because program buffers can contain pointers as values, we need to
   consider its impact in initial program state, global environments, and even
   program well-formedness. *)
Record well_formed_program (p: program) := {
  (* the interface is sound (but maybe not closed)
     RB: Currently not used in the proofs. *)
  wfprog_interface_soundness:
    sound_interface (prog_interface p);
  (* there are procedures only for the declared components *)
  wfprog_defined_procedures:
    domm (prog_interface p) = domm (prog_procedures p);
  (* each exported procedure actually exists *)
  wfprog_exported_procedures_existence:
    forall C CI,
      getm (prog_interface p) C = Some CI ->
    forall P,
      Component.is_exporting CI P ->
    exists Cprocs Pcode,
      getm (prog_procedures p) C = Some Cprocs /\
      getm Cprocs P = Some Pcode;
  (* each instruction of each procedure is well-formed *)
  wfprog_well_formed_instructions:
    forall C Cprocs,
      getm (prog_procedures p) C = Some Cprocs ->
    forall P Pcode,
      getm Cprocs P = Some Pcode ->
    forall i, In i Pcode -> well_formed_instruction p C P i;
  (* there are buffers only for the declared components *)
  wfprog_defined_buffers:
    domm (prog_interface p) = domm (prog_buffers p);
  (* buffers may not contain pointer values *)
  wfprog_well_formed_buffers:
    forall C buf,
      prog_buffers p C = Some buf ->
      (*b \in domm bufs -> *)
      Buffer.well_formed_buffer buf;
      (*Buffer.well_formed_buffer_opt (bufs b);*)
  (* if the main component exists, then the main procedure must exist as well *)
  wfprog_main_existence:
      prog_main p ->
    exists main_procs,
      getm (prog_procedures p) Component.main = Some main_procs /\ Procedure.main \in domm main_procs;
  (* Iff the main component is in the interface, a main procedure is given. *)
  wfprog_main_component:
    (* (RB: Old-style fix, later changed from a simple implication.) *)
    (* prog_main p = None -> *)
    (* Component.main \notin domm (prog_interface p) *)
    Component.main \in domm (prog_interface p) <->
    prog_main p;
  (* wfprog_main_id: *)
  (*   forall mainP, *)
  (*     prog_main p = Some mainP -> *)
  (*     mainP = 0 *)
}.

(* a closed program is a program with a closed interface and an existing main
   procedure *)
Record closed_program (p: program) := {
  (* the interface must be closed (and consequently sound) *)
  cprog_closed_interface:
    closed_interface (prog_interface p);
  (* the main procedure must exist *)
  cprog_main_existence:
    exists main_procs,
      prog_main p /\
      getm (prog_procedures p) Component.main = Some main_procs /\ 0 \in domm main_procs
}.

Definition linkable_mains (prog1 prog2 : program) : Prop :=
  ~~ (prog_main prog1 && prog_main prog2).

Lemma linkable_mains_sym : forall (prog1 prog2 : program),
  linkable_mains prog1 prog2 -> linkable_mains prog2 prog1.
Proof.
  intros prog1 prog2.
  unfold linkable_mains, andb, negb.
  destruct (prog_main prog1);
    destruct (prog_main prog2);
    intuition.
Qed.

(* RB: TODO: Remove superfluous linkable_main assumptions from development.
   Observe the relation to PS.domm_partition_in_union_in_neither. *)
Theorem linkable_implies_linkable_mains : forall (p1 p2 : program),
  well_formed_program p1 ->
  well_formed_program p2 ->
  linkable (prog_interface p1) (prog_interface p2) ->
  linkable_mains p1 p2.
Proof.
  intros p1 p2 Hwf1 Hwf2 [_ Hdisjoint].
  unfold linkable_mains.
  destruct (prog_main p1) as [|] eqn:Hmain1;
    destruct (prog_main p2) as [|] eqn:Hmain2;
    try reflexivity.
  (* All that remains is the contradictory case. *)
  pose proof (proj2 (wfprog_main_component Hwf1)) as Hdomm1.
  rewrite Hmain1 in Hdomm1. specialize (Hdomm1 isT).
  pose proof (proj2 (wfprog_main_component Hwf2)) as Hdomm2.
  rewrite Hmain2 in Hdomm2. specialize (Hdomm2 isT).
  pose proof @fdisjointP _ _ _ Hdisjoint _ Hdomm1 as Hcontra.
  now rewrite Hdomm2 in Hcontra.
Qed.

Definition matching_mains (prog1 prog2 : program) : Prop :=
  prog_main prog1 <-> prog_main prog2.

Definition program_link (p1 p2: program): program :=
  {| prog_interface := unionm (prog_interface p1) (prog_interface p2);
     prog_procedures := unionm (prog_procedures p1) (prog_procedures p2);
     prog_buffers := unionm (prog_buffers p1) (prog_buffers p2);
     prog_main := prog_main p1 || prog_main p2 |}.

Lemma program_linkC p1 p2 :
  well_formed_program p1 ->
  well_formed_program p2 ->
  linkable (prog_interface p1) (prog_interface p2) ->
  program_link p1 p2 = program_link p2 p1.
Proof.
  case: p1 p2 => [i1 p1 b1 m1] [i2 p2 b2 m2] /= Hwf1 Hwf2 [_ Hdis_i].
  have Hdis_p: fdisjoint (domm p1) (domm p2).
    by rewrite -(wfprog_defined_procedures Hwf1) -(wfprog_defined_procedures Hwf2).
  congr mkProg=> /=; try rewrite unionmC //.
    by rewrite -(wfprog_defined_buffers Hwf1) -(wfprog_defined_buffers Hwf2).
      by rewrite orb_comm.
Qed.

Theorem linking_well_formedness:
  forall p1 p2,
    well_formed_program p1 ->
    well_formed_program p2 ->
    linkable (prog_interface p1) (prog_interface p2) ->
    well_formed_program (program_link p1 p2).
Proof.
  move=> p1 p2 Hwf1 Hwf2 [Hsound Hdis_i]; split=> //.
  - simpl.
    repeat rewrite domm_union.
    by do 2![rewrite wfprog_defined_procedures //].
  - move=> /= C CI H1 P H2.
    rewrite unionmE -mem_domm -(wfprog_defined_procedures Hwf1) !mem_domm.
    rewrite unionmE in H1.
    case Hwhere: (prog_interface p1 C) H1 => [CI'|] //=.
    + move=> [?]; subst CI'.
      destruct (wfprog_exported_procedures_existence Hwf1 Hwhere H2)
        as [Cprocs [Pcode [Hproc Hcode]]].
      rewrite Hproc. simpl.
      exists Cprocs. exists Pcode.
      split; auto.
    + suffices Hno_p1 : prog_procedures p1 C = None.
        move=> H1.
        destruct (wfprog_exported_procedures_existence Hwf2 H1 H2)
          as [Cprocs [Pcode [Hproc Hcode]]].
        exists Cprocs. exists Pcode.
        split; auto.
      now apply/dommPn; rewrite -(wfprog_defined_procedures Hwf1); apply/dommPn.
  - move=> C Cprocs H1 P Pcode H2.
    without loss H: p1 p2 Hwf1 Hwf2 Hsound Hdis_i H1 / prog_procedures p1 C = Some Cprocs.
    { move: H1; rewrite /= unionmE.
      case e: (prog_procedures p1 C)=> [Cprocs'|] //=.
        move=> [<-]; apply=> //.
        by rewrite unionmE e.
      move=> Hp2_C Hgen i Hi; rewrite program_linkC //.
      apply Hgen=> //.
      + by rewrite unionmC // fdisjointC.
      + by rewrite fdisjointC.
      + by rewrite unionmE Hp2_C. }
    move=> i Hi.
    move: (wfprog_well_formed_instructions Hwf1 H H2 Hi).
    case: i Hi=> //=.
    + (* IConst *)
      case=> // ptr r Hi [Hptr [Hperm [bufs [p1_bufs Hbufs]]]].
      split; first assumption.
      split; first assumption.
        by (exists bufs; rewrite unionmE p1_bufs).
    + (* IPtrPfLabel *)
      move=> l reg Hi [Cprocs' [P' [Pcode']]].
      rewrite H=> - [[<-] {Cprocs'}].
      case=> H2' Hl.
      by exists Cprocs, P', Pcode'; rewrite unionmE H.
    + (* IBnz *)
      move=> r l Hi [Cprocs' [Pcode']].
      rewrite H=> - [[<-] {Cprocs'}].
      rewrite H2=> - [[<-] {Pcode'}] Hl.
      by exists Cprocs, Pcode; rewrite unionmE H.
    + (* IJal *)
      move=> l Hi [Cprocs' [P' [Pcode']]].
      rewrite H=> - [[<-] {Cprocs'}].
      case=> H2' Hl.
      by exists Cprocs, P', Pcode'; rewrite unionmE H.
    + (* ICall *)
      move=> C' P' Hi [CC' [CI [p1_C Himport]]]; split=> //.
      exists CI; split=> //.
      by rewrite /Program.has_component unionmE p1_C.
  - rewrite /= !domm_union.
    by do 2![rewrite wfprog_defined_buffers //].
  - intros C buf Hbuf.
    destruct (C \in domm (prog_interface p1)) eqn:Hcase1;
      destruct (C \in domm (prog_interface p2)) eqn:Hcase2.
    + pose proof (@fdisjointP _ _ _ Hdis_i) C Hcase1 as Hcontra.
      now rewrite Hcase2 in Hcontra.
    + apply wfprog_well_formed_buffers with p1 C; auto.
      rewrite (wfprog_defined_buffers Hwf1) in Hcase1.
      pose proof dommP Hcase1 as [bufs1 Hbufs1].
      rewrite unionmE in Hbuf.
      destruct (prog_buffers p1 C) eqn:Hcase; easy.
    + apply wfprog_well_formed_buffers with p2 C; auto.
      rewrite (wfprog_defined_buffers Hwf2) in Hcase2.
      pose proof dommP Hcase2 as [bufs2 Hbufs2].
      apply negb_true_iff in Hcase1.
      rewrite (wfprog_defined_buffers Hwf1) in Hcase1.
      pose proof dommPn Hcase1 as Hbufs1.
      rewrite unionmE Hbufs1 in Hbuf.
      destruct (prog_buffers p2 C) eqn:Hcase; easy.
    + apply negb_true_iff in Hcase1.
      apply negb_true_iff in Hcase2.
      rewrite (wfprog_defined_buffers Hwf1) in Hcase1.
      rewrite (wfprog_defined_buffers Hwf2) in Hcase2.
      rewrite unionmE in Hbuf.
      rewrite (dommPn Hcase1) (dommPn Hcase2) in Hbuf.
      discriminate.
  - rewrite /=. case /orP => [mainP | mainP].
    + have Hmain1 := @wfprog_main_existence _ Hwf1 mainP.
      case: Hmain1 => [main_procs [p1_main HmainP]] //=.
        by exists main_procs; rewrite unionmE p1_main.
    + have Hmain2 := @wfprog_main_existence _ Hwf2 mainP.
      case: Hmain2 => [main_procs [p2_main HmainP]] //=.
      exists main_procs; rewrite unionmC 1?unionmE 1?p2_main //.
      by rewrite -(wfprog_defined_procedures Hwf1) -(wfprog_defined_procedures Hwf2).
  - (* Coq 8.11.2: *)
    (* Error: Anomaly "make_elim_branch_assumptions." Please report at http://coq.inria.fr/bugs/. *)
    inversion Hwf1 as [_ _ _ _ _ _ DUMMY Hmain_comp1]; clear DUMMY.
    inversion Hwf2 as [_ _ _ _ _ _ DUMMY Hmain_comp2]; clear DUMMY.
    split;
      intros Hprog_main1.
    + assert (Hprog_main2 := Hprog_main1).
      simpl in *.
      destruct (Component.main \in domm (prog_interface p1)) eqn:Hcase1;
        destruct (Component.main \in domm (prog_interface p2)) eqn:Hcase2.
      * (* Contra/easy. *)
        pose proof (proj1 Hmain_comp1 Hcase1) as Hmain1. now rewrite Hmain1.
      * apply proj1 in Hmain_comp1.
        specialize (Hmain_comp1 Hcase1). rewrite Hmain_comp1. by [].
      * destruct (prog_main p1) as [main1 |] eqn:Hmain1.
        -- reflexivity.
        -- apply proj1 in Hmain_comp2.
           specialize (Hmain_comp2 Hcase2). assumption.
      * (* Contra. *)
        destruct (@dommP _ _ _ _ Hprog_main1) as [CI HCI]. rewrite unionmE in HCI.
        apply negb_true_iff in Hcase1. apply negb_true_iff in Hcase2.
        now rewrite (@dommPn _ _ _ _ Hcase1) (@dommPn _ _ _ _ Hcase2) in HCI.
    + inversion Hprog_main1 as [Hmain].
      destruct (prog_main p1) as [main1 |] eqn:Hcase1;
        destruct (prog_main p2) as [main2 |] eqn:Hcase2.
      * (* Contra/easy. RB: NOTE: Three cases can be solved as instances of a
           little lemma, or a tactic. Is it useful elsewhere? *)
        apply proj2 in Hmain_comp1. specialize (Hmain_comp1 isT).
        destruct (@dommP _ _ _ _ Hmain_comp1) as [CI HCI].
        apply /dommP. exists CI. now rewrite unionmE HCI.
      * apply proj2 in Hmain_comp1. specialize (Hmain_comp1 isT).
        destruct (@dommP _ _ _ _ Hmain_comp1) as [CI HCI].
        apply /dommP. exists CI. now rewrite unionmE HCI.
      * apply proj2 in Hmain_comp2. specialize (Hmain_comp2 isT).
        destruct (@dommP _ _ _ _ Hmain_comp2) as [CI HCI].
        apply /dommP. exists CI. simpl. now rewrite (unionmC Hdis_i) unionmE HCI.
      * discriminate.
Qed.

(* Given a list of components, create the map that associates to
   each component the preallocated buffers according to program p.
   If no buffers are found, use the empty map as a default (this
   will not happen in regular use!). *)
Definition alloc_static_buffers p comps :=
  mkfmapf (fun C =>
             ComponentMemory.prealloc
                  (
                    match prog_buffers p C with
                    | Some buf => mkfmap [(Block.local, buf)]
                    | None => emptym
                    end
                  )
          )
          comps.

Definition prepare_initial_memory (p: program) : Memory.t :=
  alloc_static_buffers p (domm (prog_interface p)).

Definition is_main_proc p comp_id proc_id :=
  match prog_main p with
  | true =>
    (Component.main =? comp_id) && (Procedure.main =? proc_id)
  | false => false
  end.

Definition is_entrypoint_of_comp (p: program) (C: Component.id)
           (P: Procedure.id) : bool :=
  match prog_interface p C with
  | Some Ciface =>
    (P \in Component.export Ciface) || is_main_proc p C P
  | None => false
  end.

Lemma is_entrypoint_of_comp_linking p c C P:
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    is_entrypoint_of_comp p C P ->
    is_entrypoint_of_comp (program_link p c) C P.
Proof.
  intros Hwfp Hwfc Hlinkable Hentryp.
  unfold is_entrypoint_of_comp in *.
  destruct (prog_interface p C) eqn:epC; last discriminate.
  inversion Hlinkable. simpl. rewrite unionmE. rewrite epC. simpl.
  move : Hentryp => /orP => [[G | G]]; apply/orP; first by auto.
  right. unfold is_main_proc in *. destruct (prog_main p) eqn:emain; last discriminate.
  simpl. by rewrite emain.
Qed.

(* As above, replace the old function with the new, and remove accumulators. *)
Definition prepare_procedures_initial_memory_aux (p: program) :=
  mkfmapf
    (fun C =>
       let Cprocs := odflt emptym ((prog_procedures p) C) in
       let Cmem :=
           ComponentMemory.prealloc (*(odflt emptym ((prog_buffers p) C))*)
             (
               match prog_buffers p C with
               | Some buf => [fmap (Block.local, buf)]
               | None => emptym
               end
             )
       in
       let Centrypoints :=
           filter (fun pid => is_entrypoint_of_comp p C pid) (domm Cprocs)
       in
       (Cmem, Cprocs, Centrypoints)
    )
       (* reserve_component_blocks p C Cmem (elementsm Cprocs)) *)
    (domm (prog_interface p)).

(* Decompose the results of the auxiliary call, composed as a whole in the
   result of reserving component blocks, turning a map of triples into a triple
   of identically indexed maps *)
Definition prepare_procedures_initial_memory (p: program)
  : Memory.t * NMap (NMap code) * EntryPoint.t :=
  let m := prepare_procedures_initial_memory_aux p in
  (mapm (fun x => x.1.1) m, mapm (fun x => x.1.2) m, mapm snd m).

(* initialization of a linked program *)

Definition prepare_procedures_memory (p: program) : Memory.t :=
  let '(mem, _, _) := prepare_procedures_initial_memory p in
  mem.

(* RB: TODO: Relocate these simple helpers, review names, etc.
   For now, trying to keep cruft out of the higher-level proofs. *)
Lemma mapm_eq: forall (T : ordType) (S S' : Type) (m1 m2 : {fmap T -> S}) (f : S -> S'),
  m1 = m2 -> (mapm f m1) = (mapm f m2).
Proof.
  intros T S S' m1 m2 f Heq.
  subst.
  reflexivity.
Qed.

Lemma in_domm_program_link:
  forall Cid p,
    Cid \in domm (prog_interface p) ->
  forall c,
    Cid \in domm (prog_interface (program_link p c)).
Proof.
  intros Cid p Hin c.
  simpl.
  rewrite mem_domm.
  rewrite mem_domm in Hin.
  rewrite unionmE.
  rewrite Hin.
  assumption.
Qed.

Lemma domm_partition_program_link_in_neither p c :
  well_formed_program p ->
  well_formed_program c ->
  closed_program (program_link p c) ->
  Component.main \notin domm (prog_interface p) ->
  Component.main \notin domm (prog_interface c) ->
  False.
Proof.
  intros [_ _ _ _ _ _ _ [_ Hmainp]] [_ _ _ _ _ _ _ [_ Hmainc]]
         [_ [main [Hmain [_ _]]]] Hmainp' Hmainc'.
  destruct (prog_main p) as [|] eqn:Hcasep.
  - specialize (Hmainp is_true_true).
    rewrite Hmainp in Hmainp'.
    discriminate.
  - destruct (prog_main c) as [|] eqn:Hcasec.
    +  specialize (Hmainc is_true_true).
       rewrite Hmainc in Hmainc'.
       discriminate.
    + simpl in Hmain.
      rewrite Hcasep Hcasec in Hmain.
      discriminate.
Qed.

Lemma fsetid (T : ordType) (s: seq.seq T) :
  fset (fset s) = fset s.
Proof. by apply /eq_fset => x; rewrite in_fset. Qed.

(* First, prove domain preservation for all of the (already existing, plus
   recent improvements) initialization code. *)
Lemma domm_prepare_procedures_initial_memory_aux: forall p,
  (*well_formed_program p ->*)
  domm (prepare_procedures_initial_memory_aux p) = domm (prog_interface p).
Proof.
  intros p.
  unfold prepare_procedures_initial_memory_aux.
  rewrite domm_mkfmapf.
  apply fsetid.
Qed.

(* FG : maybe relocate this in extructures? (when rewritten in proper SSReflect) *)
Lemma fdisjoint_partition_notinboth (T: ordType) (s1 s2 : {fset T}) :
  fdisjoint s1 s2 ->
  forall x,
    x \in s2 ->
    x \in s1 ->
    False.
Proof.
  unfold fdisjoint. move => Hinter x Hs2 Hs1.
  have H' : x \in (s1 :&: s2)%fset by rewrite in_fsetI Hs1 Hs2.
  have H'' : (s1 :&: s2)%fset = fset0 by apply /eqP.
  rewrite H'' in H'. inversion H'.
Qed.

(* Better name, maybe ? *)
(* keeping it generic over program/context *)
Lemma prog_link_procedures_unionm :
  forall p1 p2 Cid,
    well_formed_program p1 ->
    (* well_formed_program p2 -> *)
    (Cid \in domm (prog_interface p1)) = true ->
    (Cid \in domm (prog_interface p2)) = false -> (* not used, to remove  or keep as sanity check ? *)
    (prog_procedures (program_link p1 p2)) Cid = (prog_procedures p1) Cid.
Proof.
  intros p1 p2 Cid Hwfp Hp _.
  rewrite unionmE. rewrite <- mem_domm. inversion Hwfp as [? Hproc _ _ _ _ _]. (* if no binding of 1st hypothesis : anomaly : "make_elim_branch_assumptions" *)
  rewrite Hproc in Hp. rewrite Hp. reflexivity.
Qed.

(* maybe write a tactic that does the core except the inversion ... ? *)
(* or suppress the prog_smth part and keep it generic for all types of program_link ? *)
Lemma prog_link_buffers_unionm :
  forall p1 p2 Cid,
    well_formed_program p1 ->
    (* well_formed_program p2 -> *)
    (Cid \in domm (prog_interface p1)) = true ->
    (Cid \in domm (prog_interface p2)) = false -> (* same *)
    (prog_buffers (program_link p1 p2)) Cid = (prog_buffers p1) Cid.
Proof.
  intros p1 p2 Cid Hwfp Hp _. simpl.
  rewrite unionmE. rewrite <- mem_domm. inversion Hwfp as [? _ _ _ Hbuf _ _]. (* if no binding of 1st hypothesis : anomaly : "make_elim_branch_assumptions" *)
  rewrite Hbuf in Hp. rewrite Hp. reflexivity.
Qed.

(* RB: TODO: Simplify hypotheses if possible. *)
Lemma prepare_procedures_initial_memory_aux_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    prepare_procedures_initial_memory_aux (program_link p c) =
    unionm (prepare_procedures_initial_memory_aux p)
           (prepare_procedures_initial_memory_aux c).
Proof.
  intros p c Hwfp Hwfc Hlinkable.
  pose proof linkable_implies_linkable_mains Hwfp Hwfc Hlinkable as Hmains.
  unfold prepare_procedures_initial_memory_aux.
  apply eq_fmap. intros Cid.
  (* Case analysis on component provenance after some common preprocessing. *)
  destruct (Cid \in domm (prog_interface p)) eqn:Hp;
    destruct (Cid \in domm (prog_interface c)) eqn:Hc.
  - (* Contra. *)
    inversion Hlinkable as [_ Hdisjoint].
    have Hcontra : False by apply (fdisjoint_partition_notinboth Hdisjoint Hc Hp).
    inversion Hcontra.
  - rewrite !unionmE.
    rewrite !mkfmapfE.
    rewrite Hp Hc.
    have Hpc : Cid \in domm (prog_interface (program_link p c))
      by apply in_domm_program_link.
    rewrite Hpc.
    have Helts :
      (domm (odflt emptym ((prog_procedures (program_link p c)) Cid))) =
      (domm (odflt emptym ((prog_procedures p) Cid)))
      by rewrite (prog_link_procedures_unionm Hwfp Hp Hc).
    rewrite Helts.
    have Hprealloc :
      ComponentMemory.prealloc
      (*(odflt emptym ((prog_buffers (program_link p c)) Cid))*)
        (
          match prog_buffers (program_link p c) Cid with
          | Some buf => [fmap (Block.local, buf)]
          | None => emptym
          end
        )
      =
      ComponentMemory.prealloc (*(odflt emptym ((prog_buffers p) Cid))*)
        (
          match prog_buffers p Cid with
               | Some buf => [fmap (Block.local, buf)]
               | None => emptym
          end
        )
      by rewrite (prog_link_buffers_unionm Hwfp Hp Hc).
    rewrite Hprealloc.
    simpl.
    rewrite !unionmE.
    have [Cid_int Hp']: (exists x, (prog_interface p) Cid = Some x)
      by  apply /dommP.
    assert (exists x, prog_procedures p Cid = Some x) as [Cid_proc HCid_proc].
    { apply/dommP. by rewrite -wfprog_defined_procedures; auto. }
    rewrite HCid_proc. simpl.
    assert (Hfiltereq:
              [seq pid <- domm Cid_proc
              | is_entrypoint_of_comp (program_link p c) Cid pid]
              =
              [seq pid <- domm Cid_proc | is_entrypoint_of_comp p Cid pid]
           ).
    {
      apply eq_in_filter. unfold prop_in1. intros ? Hin.
      unfold is_entrypoint_of_comp. simpl. rewrite unionmE Hp'. simpl.
      unfold is_main_proc.
      destruct (prog_main p) as [|] eqn:Hmainp;
        destruct (prog_main c) as [|] eqn:Hmainc;
        unfold is_main_proc; simpl; rewrite Hmainp Hmainc.
      - unfold linkable_mains in *. exfalso.
        move : Hmains => /negP => Hmains. by intuition.
      - reflexivity.
      - destruct Cid as [| n].
        + (* Contra. *)
          inversion Hwfp as [_ _ _ _ _ _ _ Hmain_compp].
          apply proj1 in Hmain_compp.
          specialize (Hmain_compp Hp).
          rewrite Hmainp in Hmain_compp.
          discriminate.
        + reflexivity.
      - reflexivity.
    }
    by rewrite Hfiltereq.
  - (* RB: TODO: Refactor symmetric case to last one. *)
    rewrite !unionmE.
    rewrite !mkfmapfE.
    rewrite Hp Hc.
    have Hpc : Cid \in domm (prog_interface (program_link p c))
      by rewrite (program_linkC Hwfp Hwfc Hlinkable) ;
      apply in_domm_program_link.
    rewrite Hpc.
    have Helts: (domm (odflt emptym ((prog_procedures (program_link p c)) Cid))) =
            (domm (odflt emptym ((prog_procedures c) Cid)))
      by rewrite (program_linkC Hwfp Hwfc Hlinkable) (prog_link_procedures_unionm Hwfc Hc Hp).
    rewrite Helts.
    have Hprealloc :
      ComponentMemory.prealloc
      (*(odflt emptym ((prog_buffers (program_link p c)) Cid))*)
        (
          match prog_buffers (program_link p c) Cid with
          | Some buf => [fmap (Block.local, buf)]
          | None => emptym
          end
        )
      =
      ComponentMemory.prealloc (*(odflt emptym ((prog_buffers p) Cid))*)
        (
          match prog_buffers c Cid with
               | Some buf => [fmap (Block.local, buf)]
               | None => emptym
          end
        )

      by rewrite (program_linkC Hwfp Hwfc Hlinkable) (prog_link_buffers_unionm Hwfc Hc Hp).
    rewrite Hprealloc.
    simpl.
    rewrite !unionmE.
    have Hp': (prog_interface p) Cid = None
      by apply /dommPn; rewrite Hp.
    have [Cid_int Hc'] : exists x, (prog_interface c) Cid = Some x
      by apply /dommP.
    assert (prog_procedures p Cid = None) as HCid_proc.
    { apply/dommPn. rewrite -wfprog_defined_procedures; auto. by apply/dommPn. }
    rewrite HCid_proc. simpl.
    assert (Hfiltereq:
              [seq pid <- domm (odflt emptym (prog_procedures c Cid))
              | is_entrypoint_of_comp (program_link p c) Cid pid]
              =
              [seq pid <- domm (odflt emptym (prog_procedures c Cid)) |
               is_entrypoint_of_comp c Cid pid]
           ).
    {
      apply eq_in_filter. unfold prop_in1. intros ? Hin.
      unfold is_entrypoint_of_comp. simpl. rewrite unionmE Hp'. simpl.
      unfold is_main_proc.
      destruct (prog_main p) as [|] eqn:Hmainp;
        destruct (prog_main c) as [|] eqn:Hmainc;
        unfold is_main_proc; simpl; rewrite Hmainp Hmainc.
      - (* Contra. *)
        unfold linkable_mains in Hmains.
        rewrite Hmainp Hmainc in Hmains.
        discriminate.
      - simpl.
        destruct Cid as [| n].
        + (* Contra, *)
          inversion Hwfc as [_ _ _ _ _ _ _ Hmain_compc].
          apply proj1 in Hmain_compc.
          specialize (Hmain_compc Hc).
          rewrite Hmainc in Hmain_compc.
          discriminate.
        + reflexivity.
      - simpl. reflexivity.
      - simpl. reflexivity.
    }
    by rewrite Hfiltereq.
  - (* in neither, pretty immediate *)
    by rewrite unionmE !mkfmapfE domm_union in_fsetU Hp Hc.
Qed.

(* Now it's easy to extend this to the parts of the final result. *)
Lemma domm_prepare_procedures_memory: forall p,
  domm (prepare_procedures_memory p) = domm (prog_interface p).
Proof.
  intros p.
  unfold prepare_procedures_memory, prepare_procedures_initial_memory.
  rewrite domm_map.
  rewrite domm_prepare_procedures_initial_memory_aux.
  reflexivity.
Qed.

Theorem prepare_procedures_memory_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    prepare_procedures_memory (program_link p c) =
    unionm (prepare_procedures_memory p) (prepare_procedures_memory c).
Proof.
  intros p c Hwfp Hwfc Hlinkable.
  unfold prepare_procedures_memory,
         prepare_procedures_initial_memory, prepare_procedures_initial_memory_aux.
  rewrite <- mapm_unionm. apply mapm_eq.
  apply prepare_procedures_initial_memory_aux_after_linking; assumption.
Qed.

(* Search _ prepare_procedures_memory. *)
(* Search _ PS.to_partial_memory unionm. *)
Lemma prepare_procedures_memory_left p c :
  linkable (prog_interface p) (prog_interface c) ->
  to_partial_memory
    (unionm (prepare_procedures_memory p) (prepare_procedures_memory c))
    (domm (prog_interface c)) =
  prepare_procedures_memory p.
Proof.
  intros [_ Hdisjoint].
  unfold to_partial_memory, merge_memories.
  rewrite <- domm_prepare_procedures_memory,
         -> filterm_union,
         -> fdisjoint_filterm_full,
         -> fdisjoint_filterm_empty, -> unionm0;
    first reflexivity;
    try rewrite -> !domm_prepare_procedures_memory; congruence.
Qed.

Lemma prepare_procedures_memory_right p c :
  linkable (prog_interface p) (prog_interface c) ->
  to_partial_memory
    (unionm (prepare_procedures_memory p) (prepare_procedures_memory c))
    (domm (prog_interface p)) =
  prepare_procedures_memory c.
Proof.
  intros Hlinkable.
  rewrite unionmC; try assumption.
  apply prepare_procedures_memory_left with (c := p) (p := c).
  now apply linkable_sym.
  inversion Hlinkable.
  now rewrite !domm_prepare_procedures_memory.
Qed.

Definition prepare_procedures_procs (p: program) : NMap (NMap code) :=
  let '(_, procs, _) := prepare_procedures_initial_memory p in
  procs.

Theorem prepare_procedures_procs_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    prepare_procedures_procs (program_link p c) =
    unionm (prepare_procedures_procs p) (prepare_procedures_procs c).
Proof.
  intros p c Hwfp Hwfc Hlinkable.
  unfold prepare_procedures_procs,
         prepare_procedures_initial_memory, prepare_procedures_initial_memory_aux.
  rewrite <- mapm_unionm. apply mapm_eq.
  apply prepare_procedures_initial_memory_aux_after_linking; assumption.
Qed.

Theorem prepare_procedures_procs_prog_procedures :
  forall p C Cprocs b Pcode,
    well_formed_program p ->
    prepare_procedures_procs p C = Some Cprocs ->
    Cprocs b = Some Pcode ->
  exists Cprocs' b',
    prog_procedures p C = Some Cprocs' /\
    Cprocs' b' = Some Pcode.
Proof.
  unfold prepare_procedures_procs,
         prepare_procedures_initial_memory,
         prepare_procedures_initial_memory_aux.
  setoid_rewrite mapmE.
  unfold omap, obind, oapp.
  setoid_rewrite mkfmapfE.
  intros p C Cprocs b Pcode Hwf Hprocs Hcode.
  destruct (C \in domm (prog_interface p)) eqn:Hdomm;
    rewrite Hdomm in Hprocs;
    [| discriminate].
  injection Hprocs as Hprocs; subst Cprocs.
  destruct (prog_procedures p C) as [Cprocs |] eqn:Hprocs;
    [| rewrite (wfprog_defined_procedures Hwf) in Hdomm;
       destruct (dommP Hdomm) as [procs Hcontra];
       discriminate].
  unfold elementsm in Hcode. simpl in Hcode.
  rewrite (wfprog_defined_buffers Hwf) in Hdomm.
  destruct (dommP Hdomm) as [Cbufs HCbufs]. by eauto.
Qed.

Definition prepare_procedures_entrypoints (p: program) : EntryPoint.t :=
  let '(_, _, entrypoints) := prepare_procedures_initial_memory p in
  entrypoints.

Lemma domm_prepare_procedures_entrypoints: forall p,
  domm (prepare_procedures_entrypoints p) = domm (prog_interface p).
Proof.
  intros p.
  unfold prepare_procedures_entrypoints, prepare_procedures_initial_memory.
  rewrite domm_map.
  rewrite domm_prepare_procedures_initial_memory_aux.
  reflexivity.
Qed.

Theorem prepare_procedures_entrypoints_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    prepare_procedures_entrypoints (program_link p c) =
    unionm (prepare_procedures_entrypoints p)
           (prepare_procedures_entrypoints c).
Proof.
  intros p c Hwfp Hwfc Hlinkable.
  unfold prepare_procedures_entrypoints,
         prepare_procedures_initial_memory, prepare_procedures_initial_memory_aux.
  rewrite <- mapm_unionm. apply mapm_eq.
  apply prepare_procedures_initial_memory_aux_after_linking; assumption.
Qed.

Corollary prepare_procedures_initial_memory_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    prepare_procedures_initial_memory (program_link p c) =
    (unionm (prepare_procedures_memory p)
            (prepare_procedures_memory c),
     unionm (prepare_procedures_procs p)
            (prepare_procedures_procs c),
     unionm (prepare_procedures_entrypoints p)
            (prepare_procedures_entrypoints c)).
Proof.
  intros p c Hwfp Hwfc Hlinkable.
  rewrite <- prepare_procedures_memory_after_linking; try assumption.
  rewrite <- prepare_procedures_procs_after_linking; try assumption.
  rewrite <- prepare_procedures_entrypoints_after_linking; try assumption.
  reflexivity.
Qed.

(* Remark le_0_Zneg n : ~ (0 <= Z.neg n)%Z. *)
(* Proof. *)
(*   induction n. *)
(*   - rewrite Pos2Z.neg_xI. omega. *)
(*   - rewrite Pos2Z.neg_xO. omega. *)
(*   - omega. *)
(* Qed. *)

(* We can prove a stronger theorem stating the correspondence of static buffer
   identifiers in the program and the environment. *)
(* Use ComponentMemoryExtra.reserve_blocks_prealloc *)
Theorem prepare_procedures_memory_prog_buffers :
  forall p ptr v,
    well_formed_program p ->
    Memory.load (prepare_procedures_memory p) ptr = Some v ->
  exists (*Cbufs*) buf,
    (prog_buffers p (Pointer.component ptr)) = Some buf /\
    (*Cbufs (Pointer.block ptr) = Some buf /\*)
    Buffer.nth_error buf (Pointer.offset ptr) = Some v.
Proof.
  unfold prepare_procedures_memory,
         prepare_procedures_initial_memory,
         prepare_procedures_initial_memory_aux.
(* TODO: Encapsulate! *)
Local Transparent Memory.load.
  unfold Memory.load.
Local Opaque Memory.load.
  setoid_rewrite mapmE.
  unfold omap, obind, oapp.
  setoid_rewrite mkfmapfE.
  intros p [[[perm C] b] o] v Hwf Hload.
  destruct (Permission.eqb perm Permission.data) eqn:Hperm;
    rewrite Hperm in Hload;
    [| discriminate].
  destruct (C \in domm (prog_interface p)) eqn:Hdomm;
    rewrite Hdomm in Hload;
    [| discriminate].
  simpl in Hload.
  rewrite (wfprog_defined_buffers Hwf) in Hdomm.
  move: Hdomm => /dommP => [[buf Hbuf]].
  (*rewrite Hbuf in Hcase. simpl in Hcase.*)
  rewrite ComponentMemory.load_prealloc in Hload.
  destruct (0 <=? o)%Z eqn:Hoff;
    [| discriminate].
  rewrite Hbuf in Hload.
  destruct ((*Cbufs b*) setm emptym Block.local buf b) as [buf_descr |] eqn:Hb;
    [| discriminate].
  simpl. exists (*Cbufs,*) buf_descr.
  rewrite Hbuf. rewrite setmE in Hb.
  destruct (@eq_op (Ord.eqType nat_ordType) b Block.local) eqn:eb; try discriminate.
  inversion Hb; subst; clear Hb. intuition.
  unfold Buffer.nth_error.
  destruct o as [| op | on].
  - destruct buf_descr as [n | vs].
    + rewrite ltb_0_Z_nat in Hload. assumption.
    + assumption.
  - destruct buf_descr as [n | vs].
    + rewrite ltb_Z_nat in Hload. assumption.
    + assumption.
  - discriminate.
Qed.

(* Alternative statements? *)
Theorem prog_buffer_ptr :
  forall p C (*bufs b*) buf o ptr,
    well_formed_program p ->
    prog_buffers p C = Some buf ->
    (*bufs b = Some buf ->*)
    Buffer.nth_error buf o = Some (Ptr ptr) ->
    False.
Proof.
  intros p C (*bufs b*) buf o ptr Hwf (*Hbufs*) Hbuf Hptr.
  pose proof wfprog_well_formed_buffers Hwf Hbuf as Hwfb.
  unfold Buffer.well_formed_buffer_opt in Hwfb.
  destruct buf as [n | vs].
  - destruct o as [| op | on]; simpl in Hptr.
    + destruct (0 <? n); discriminate.
    + destruct (Pos.to_nat op <? n); discriminate.
    + discriminate.

  - destruct o as [| op | on]; simpl in Hptr.
    + destruct vs as [| v vs];
        [discriminate |].
      injection Hptr as Hptr; subst v.
      move: Hwfb => /andP => [[Hsize Hptrs]].
      discriminate.
    + move: Hwfb => /andP => [[Hsize Hptrs]].
      apply nth_error_In in Hptr.
      apply In_in in Hptr.
      move: Hptrs => /allP => Hcontra.
      specialize (Hcontra _ Hptr).
      discriminate.
    + discriminate.
Qed.

(* RB: Slight "misnomer" because of the presence of matching_mains.
   Closely connected to linkable, but not exactly the same at this
   level. Is there a benefit to combining these two in a definition? *)
Lemma interface_preserves_closedness_r :
  forall p1 p2 p2',
    well_formed_program p1 ->
    well_formed_program p2' ->
    prog_interface p2 = prog_interface p2' ->
    linkable (prog_interface p1) (prog_interface p2) ->
    closed_program (program_link p1 p2) ->
    linkable_mains p1 p2 ->
    matching_mains p2 p2' ->
    closed_program (program_link p1 p2').
Proof.
  intros p1 p2 p2'
         Hwf1 Hwf2' Hsame_int Hlinkable
         [Hclosed [mainP [Hmain [Hprocs]]]]
         Hlinkable_mains Hmatching_mains.
  constructor.
  - simpl in Hclosed.
    rewrite Hsame_int in Hclosed.
    apply Hclosed.
  - destruct (prog_main p1) as [|] eqn:Hmain1;
      destruct (prog_main p2) as [|] eqn:Hmain2.
    + unfold linkable_mains in Hlinkable_mains.
      rewrite Hmain1 Hmain2 in Hlinkable_mains.
      discriminate.
    + (* main is in p1.*)
      (* unfold program_link in Hmain. *)
      (* rewrite Hmain1 in Hmain. *)
      (* simpl in Hmain. *)
      (* inversion Hmain; subst mainP; clear Hmain. *)
      (* Likewise main_procs (used only in second sub-goal). *)
      unfold program_link in Hprocs; simpl in Hprocs.
      destruct (wfprog_main_existence Hwf1 Hmain1)
        as [main_procs1 [Hmain_procs1 Hin1]].
      rewrite unionmE Hmain_procs1 in Hprocs.
      (* inversion Hprocs; subst main_procs; clear Hprocs. *)
      (* Instantiate and solve. *)
      exists main_procs1. split; [| split].
      * unfold program_link.
        rewrite Hmain1.
        reflexivity.
      * unfold program_link; simpl.
        rewrite unionmE Hmain_procs1.
        reflexivity.
      * assumption.
    + (* main is in p2'. *)
      destruct (prog_main p2') as [|] eqn:Hmain2';
      last (destruct Hmatching_mains as [Hmatching_mains _];
            rewrite Hmatching_mains in Hmain2';
            last assumption;
            inversion Hmain2').
      (* Likewise main_procs (used only in second sub-goal). *)
      destruct (wfprog_main_existence Hwf2' Hmain2')
        as [main_procs2' [Hmain_procs2' Hin2']].
      exists main_procs2'. split; [| split].
      * unfold program_link.
        rewrite Hmain1 Hmain2'.
        reflexivity.
      * unfold program_link; simpl.
        inversion Hlinkable as [_ Hdisjoint].
        inversion Hwf1 as [_ Hdomm1 _ _ _ _].
        inversion Hwf2' as [_ Hdomm2' _ _ _ _].
        rewrite Hsame_int Hdomm1 Hdomm2' in Hdisjoint.
        rewrite (unionmC Hdisjoint) unionmE Hmain_procs2'.
        reflexivity.
      * assumption.
    + simpl in Hmain.
      rewrite Hmain1 in Hmain.
      rewrite Hmain2 in Hmain.
      discriminate.
Qed.

(* RB: TODO: Revisit uses of matching_mains as hypotheses and see when they can
   be removed due to their being derivable from this result. *)
Lemma interface_implies_matching_mains :
  forall p1 p2,
    well_formed_program p1 ->
    well_formed_program p2 ->
    prog_interface p1 = prog_interface p2 ->
    matching_mains p1 p2.
Proof.
  intros p1 p2 Hwf1 Hwf2 Hiface.
  unfold matching_mains.
  destruct (prog_main p1) as [|] eqn:Hcase1;
    destruct (prog_main p2) as [|] eqn:Hcase2.
  - easy.
  - split; last easy.
    exfalso.
    inversion Hwf2 as [_ _ _ _ _ _ _ [Hmain2' _]].
    inversion Hwf1 as [_ _ _ _ _ _ _ [_ Hmain1']].
    rewrite Hcase1 in Hmain1'. specialize (Hmain1' is_true_true).
    rewrite -> Hcase2, <- Hiface in Hmain2'. apply Hmain2' in  Hmain1'.
    discriminate.
  - split; first easy.
    exfalso.
    inversion Hwf1 as [_ _ _ _ _ _ _ [Hmain1' _]].
    inversion Hwf2 as [_ _ _ _ _ _ _ [_ Hmain2']].
    rewrite Hcase2 in Hmain2'. specialize (Hmain2' is_true_true).
    rewrite -> Hcase1, -> Hiface in Hmain1'. apply Hmain1' in  Hmain2'.
    discriminate.
  - easy.
Qed.

Lemma closed_interface_union : forall p1 p2,
  closed_interface (prog_interface (program_link p1 p2)) =
  closed_interface (unionm (prog_interface p1) (prog_interface p2)).
Proof.
  easy.
Qed.

Lemma compose_mergeable_interfaces : forall p1 p2,
  linkable (prog_interface p1) (prog_interface p2) ->
  closed_program (program_link p1 p2) ->
  mergeable_interfaces (prog_interface p1) (prog_interface p2).
Proof.
  intros p1 p2 Hlinkable Hclosed.
  split.
  - assumption.
  - inversion Hclosed as [Hclosed_iface _].
    rewrite closed_interface_union in Hclosed_iface.
    assumption.
Qed.

End Intermediate.


Require Import Tac Var.
Require Import MSetWeakList MSetProperties Program.Basics.

Module S := MSetWeakList.Make VarEq.
Module SF := MSetProperties.WPropertiesOn VarEq S.

Notation Env := S.t.

Notation env_empty := S.empty.
Notation env_add := S.add.
Notation env_mem := S.In.

Lemma env_mem_add :
  forall e x y,
  x <> y ->
  env_mem y (env_add x e) ->
  env_mem y e.
Proof. apply SF.Dec.F.add_3. Qed.

Lemma env_add_mem :
  forall e x y,
  env_mem x e ->
  env_mem x (env_add y e).
Proof. intros e x y H. apply S.add_spec; auto. Qed.

Lemma env_add_mem' :
  forall e x,
  env_mem x (env_add x e).
Proof. intros. apply SF.Dec.F.add_1. auto. Qed.

Lemma env_mem_empty :
  forall x,
  ~ (env_mem x env_empty).
Proof. unfold not. apply SF.FM.empty_iff. Qed.


Require Import FloydSeq.base2.
Require Import FloydSeq.client_lemmas.
Require Import CSplit.strong.
Import ListNotations.

(* In any of these functions, whenever there is a [list ident],
  we assume it is unsorted without duplicates. *)

(* Take the union of two lists *)
Fixpoint deadvars_union (al bl: list ident) : list ident :=
 match al with
 | a::al' => let cl := deadvars_union al' bl in
                   if id_in_list a bl then cl else a::cl
 | nil => bl
 end.
(* Take the intersection of two lists *)
Fixpoint deadvars_intersection (al bl: list ident) : list ident :=
 match al with
 | a::al' => if id_in_list a bl
                then a :: deadvars_intersection al' bl
                else deadvars_intersection al' bl
 | nil => nil
 end.

(* Assume [vl,live] are disjoint.  If [i] is present in [vl], move it to [live] *)
Fixpoint deadvars_remove1 i vl live :=
 match vl with
 | j::vl' => if Pos.eqb i j
             then (vl', i::live)
             else let (vl2, live2) := deadvars_remove1 i vl' live
                     in (j::vl2, live2)
 | nil => (nil, live)
 end.

(* Whenever  (vl',live')=deadvars_remove e vl live,   that means
    disjoint [vl,live],   disjoint [vl',live'],   [vl U live]=[vl' U live'],
    and vl' is the maximal subset of vl that contains no tempvar of e *)
Fixpoint deadvars_remove (e: expr) (vl live: list ident) : list ident * list ident :=
 match e with
 | Etempvar i _ => deadvars_remove1 i vl live
 | Ederef e1 _ => deadvars_remove e1 vl live
 | Eaddrof e1 _ => deadvars_remove e1 vl live
 | Eunop _ e1 _ => deadvars_remove e1 vl live
 | Ebinop _ e1 e2 _ => let (vl', live') := deadvars_remove e1 vl live
                                    in deadvars_remove e2 vl' live'
 | Ecast e1 _ => deadvars_remove e1 vl live
 | Efield e1 _ _ => deadvars_remove e1 vl live
 | _ => (vl, live)
 end.

(* Whenever  (vl',live')=deadvars_removel e vl live,   that means
    disjoint [vl,live],   disjoint [vl',live'],   [vl U live]=[vl' U live'],
    and vl' is the maximal subset of vl that contains no tempvar of el *)
Fixpoint deadvars_removel (el: list expr) (vl live: list ident) : list ident * list ident :=
  match el with
  | nil => (vl , live)
  | e::el' => let (vl', live') := deadvars_remove e vl live
                   in deadvars_removel el' vl' live'
  end.

Fixpoint deadvars_dead (i: ident) (vl: list ident) : list ident * list ident :=
 match vl with
 | j::vl' => if Pos.eqb i j
             then ([i],vl')
             else let (k,vl'') := deadvars_dead i vl' in (k,j::vl')
 | nil => (nil, nil)
 end.

(* (vl',live')=deadvars_delete al vl live,   that means
    disjoint [vl,live],   disjoint [vl',live'],   [vl U live]=[vl' U live'],
    and vl' is the maximal subset of vl that contains no element of al *)
Fixpoint deadvars_delete (al vl live: list ident) : list ident * list ident :=
 match al with
 | a::al' => let (vl',live') := deadvars_delete al' vl live
                   in deadvars_remove1 a vl' live'
 | nil => (vl,live)
 end.

Fixpoint nobreaks (s: statement) : bool :=
match s with
| Sbreak => false
| Scontinue => false
| Ssequence c1 c2 => nobreaks c1 && nobreaks c2
| Sloop c1 c2 => nobreaks c1 && nobreaks c2
| Sifthenelse _ c1 c2 => nobreaks c1 && nobreaks c2
| _ => true
end.

(* (live'',dead'') = deadvars_stmt vl live dead c (fun vl' live' dead' => B) (bcont)    means,
   Let ubd = the variables of vl, used-before-defined in c
   Let def = variables of vl, defined-before-used in c
   Let vl = ubd U def U vl'
   That is, ubd we know for sure are live before c,
     def we know for sure are dead,
     and vl' we need to keep investigating the commands after c.
   Finally, live' = ubd U live,      dead' = def U dead
     and we continue the flow analysis with B, or for break statements we continue with bcont.
   What's returned is a pair (live'',dead'') such that live'' U dead'' = vl.  *)
Fixpoint deadvars_stmt (vl: list ident) (live dead: list ident) (c: statement)
                   (cont bcont: list ident -> list ident -> list ident -> list ident * list ident) : list ident * list ident :=
  match vl with nil => (live,dead) | _ =>
   match c with
   | Sskip => cont vl live dead
   | Sassign e1 e2 => let (vl',live') := deadvars_removel [e1;e2] vl live in
                         cont vl' live' dead
   | Sset i e => let (vl',live') := deadvars_remove e vl live in
                     let (d,vl'') := deadvars_dead i vl' in
                      cont vl'' live' (d++dead)
   | Scall i e el => let (vl',live') := deadvars_removel (e::el) vl live in
                      let (d,vl'') := match i with
                                      | Some i' => deadvars_dead i' vl'
                                      | None => (nil,vl')
                                      end
                      in cont vl'' live' (d++dead)
   | Sbuiltin i ef tl el =>
                     let (vl',live') := deadvars_removel el vl live in
                      let (d,vl'') := match i with
                                      | Some i' => deadvars_dead i' vl'
                                      | None => (nil,vl')
                                      end
                      in cont vl'' live' (d++dead)
   | Ssequence c1 c2 =>
          deadvars_stmt vl live dead c1 (fun vl' live' dead' =>
             deadvars_stmt vl' live' dead' c2 cont bcont) bcont
   | Sreturn None => (nil, vl++dead)
   | Sreturn (Some e) => let (vl',live') := deadvars_removel [e] vl live
                          in (live', vl' ++ dead)
   | Sifthenelse e c1 c2 =>
      if nobreaks c1 && nobreaks c2
      then
           let (vl', live')  := deadvars_removel [e] vl live in
            let (live1,dead1) := deadvars_stmt vl' nil dead c1 (fun _ l d => (l,d)) bcont in
            let (live2,dead2) := deadvars_stmt vl' nil dead c2 (fun _ l d => (l,d)) bcont in
            let live'' := deadvars_union live1 live2 in
            let dead'' := deadvars_intersection dead1 dead2 in
            let (vl'',live3) := deadvars_delete live'' vl' live' in
            let (vl3, _) := deadvars_delete dead'' vl'' nil in
            cont vl3 live3 dead''
     else
           let (vl', live')  := deadvars_removel [e] vl live in
            let (live1,dead1) := deadvars_stmt vl' live' dead c1 cont bcont in
            let (live2,dead2) := deadvars_stmt vl' live' dead c2 cont bcont in
            let live'' := deadvars_union live1 live2 in
            let dead'' := deadvars_intersection dead1 dead2 in
            (live'',dead'')
   | Sbreak => bcont vl live dead
   | Sloop c1 c2 =>
                             (* on the next line, using  vlx++deadx  instead of just deadx  is rather aggressive; is it sound?  *)
            let cont0 := fun vlx livex deadx => (livex,vlx++deadx) in
            let cont1 := fun vl' live' dead' => deadvars_stmt vl' live' dead' c2 cont0 cont
            in deadvars_stmt vl live dead c1 cont1 cont
   | _ => (live,dead)
   end
  end.

Fixpoint temps_of_localdefs (dl: list localdef) : list ident :=
 match dl with
 | nil => nil
 | temp i _ :: dl' => i :: temps_of_localdefs dl'
 | _ :: dl' => temps_of_localdefs dl'
 end.

(*  (live',dead') = deadvars_post post vl live dead.
  The forward flow analysis has reached a postcondition whose LOCALS clause contains
   exactly the tempvars in [post], and by this time in the forward flow analysis we have
   classified our starting variables into three disjoint lists:
     live: definitely live
     dead: definitely dead
     vl:  not yet sure.
   So now we know that the intersection of (vl, post) are all definitely live,
    and the rest of vl are definitely dead, so we can construct
      live' = (vl intersect post) ++ live
      dead' = (vl - post) ++ dead' *)
Fixpoint deadvars_post (post: list ident) (vl: list ident) (live dead: list ident) : list ident * list ident :=
 match post with
 | nil => (nil, vl++dead)
 | i :: post' => let (vl',live') := deadvars_remove1 i vl live in
                             deadvars_post post' vl' live' dead
 end.

Ltac inhabited_value T :=
 match T with
 | nat => constr:(O)
 | Z => constr:(0%Z)
 | list ?A => constr:(@nil A)
 | positive => xH
 | bool => false
 | prod ?A ?B => let x := inhabited_value A in
                           let y := inhabited_value B in
                               constr:(pair x y)
 | _ => match goal with
            | x:T |- _ => x
            | x := _ : T |- _ => x
            | _ => fail 3 "cannot prove that type" T "is inhabited, so cannot compute deadvars.  Fix this by asserting (X:"T") above the line"
            end
 end.

Fixpoint expr_temps (e: expr) (vl: list ident) : list ident :=
 match e with
 | Etempvar i _ => if id_in_list i vl then vl else i::vl
 | Ederef e1 _ => expr_temps e1 vl
 | Eaddrof e1 _ => expr_temps e1 vl
 | Eunop _ e1 _ => expr_temps e1 vl
 | Ebinop _ e1 e2 _ => expr_temps e2 (expr_temps e1 vl)
 | Ecast e1 _ => expr_temps e1 vl
 | Efield e1 _ _ => expr_temps e1 vl
 | _ => vl
 end.

Ltac locals_of_assert P :=
 lazymatch P with
 | (PROPx _ (LOCALx ?Q _)) => constr:(temps_of_localdefs Q)
 | emp => constr:(@nil ident)
 | andp ?A ?B => let a := locals_of_assert A in
                  let b := locals_of_assert B in
                  constr:(a++b)
 | sepcon ?A ?B => let a := locals_of_assert A in
                  let b := locals_of_assert B in
                  constr:(a++b)
 | @stackframe_of _ _ => constr:(@nil ident)
 | local (liftx (eq _) (eval_expr ?E)) =>
            let vl := constr:(expr_temps E nil) in vl
 | @exp _ _ ?T ?F =>
    let x := inhabited_value T in
     let d := constr:(F x) in
      let d := eval cbv beta in d in        let d := locals_of_assert d in
           d
 end.

Ltac locals_of_ret_assert Post :=
 lazymatch Post with
 | @abbreviate ret_assert ?P => locals_of_ret_assert P
 | normal_ret_assert ?P => let a := locals_of_assert P in
                                          constr:(pair a (@nil ident))
 | loop1_ret_assert ?P ?R => let a := locals_of_assert P in
                                            let b := locals_of_ret_assert R in
                                               constr:(pair a (fst b))
 | loop2_ret_assert ?P _ => let a := locals_of_assert P in
                                          constr:(pair a (@nil ident))
 | function_body_ret_assert _ _ => constr:(pair (@nil ident) (@nil ident))
 | overridePost ?P ?R => let b := locals_of_ret_assert R in
                                      let a := locals_of_assert P in
                                         constr:(pair a (snd b))
 | frame_ret_assert ?A ?B =>
     let vlA :=  locals_of_ret_assert A
      in let vlB := locals_of_assert B
       in let vl := constr:(pair (fst vlA ++ vlB) (snd vlA ++ vlB))
        in vl
 end.

Ltac find_dead_vars P c Q :=
     let vl := locals_of_assert P in
     let post := locals_of_ret_assert Q in
     let post := eval compute in post in
     let d := constr:(snd (deadvars_stmt vl nil nil c
                                     (deadvars_post (fst post))
                                     (deadvars_post (snd post)))) in
      let d := eval compute in d in
      d.

Ltac deadvars :=
 lazymatch goal with
 | X := @abbreviate ret_assert ?Q |-
    semax _ ?P ?c ?Y =>
    constr_eq X Y;
    match find_dead_vars P c Q with
    | nil => idtac
    | ?d =>  idtac "Dropping dead vars!"; drop_LOCALs d
     end + fail 99 "deadvars failed for an unknown reason"
 | |- semax _ _ _ _ =>
       fail "deadvars: Postcondition must be an abbreviated local definition (POSTCONDITION); try abbreviate_semax first"
 | |- _ |-- _ => idtac
 | |- _ => fail "deadvars: the proof goal should be a semax"
 end.

Tactic Notation "deadvars" "!" :=
 match goal with
 | X := @abbreviate ret_assert ?Q |-
    semax _ ?P ?c ?Y =>
    constr_eq X Y;
    match find_dead_vars P c Q with
    | nil => fail 2 "deadvars!: Did not find any dead variables"
    | ?d =>  drop_LOCALs d
     end
 | |- semax _ _ _ _ =>
       fail 1 "deadvars!: Postcondition must be an abbreviated local definition (POSTCONDITION); try abbreviate_semax first"
 | |- _ => fail 1 "deadvars!: the proof goal should be a semax"
 end.