From Coq Require Import Arith ZArith OrderedType.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
From nbits Require Import NBits.
From ssrlib Require Import Types SsrOrder Var Nats ZAriths Tactics Seqs.
From BitBlasting Require Import Typ TypEnv State QFBV CNF BBExport.
From BBCache Require Import BitBlastingInit CacheFlatten BitBlastingCCacheExport BitBlastingCacheExport.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ==== bit_blast_exp_fccache and bit_blast_bexp_fccache ==== *)

(* The bit-blasting with complete information is used for correctness. *)

From BBCache Require Import CCacheFlatten.

Fixpoint bit_blast_exp_fccache E m c g e : vm * ccache * generator * seq cnf * word :=
  (* = bit_blast_exp_nocet = *)
  let bit_blast_exp_nocet E m c g e : vm * ccache * generator * seq cnf * word * seq cnf :=
      match e with
      | QFBV.Evar v =>
        match find_het e c with
        | Some (cs, ls) => (m, c, g, cs, ls, cs)
        | None =>
          match SSAVM.find v m with
          | None => let '(g', cs, rs) := bit_blast_var E g v in
                    (SSAVM.add v rs m, add_het e [:: cs] rs c, g', [:: cs], rs, [:: cs])
          | Some rs => (m, add_het e [::] rs c, g, [::], rs, [::])
          end
        end
      | QFBV.Econst bs =>
        match find_het e c with
        | Some (cs, ls) => (m, c, g, cs, ls, cs)
        | None => let '(g', cs, rs) := bit_blast_const g bs in
                  (m, add_het e [:: cs] rs c, g', [:: cs], rs, [:: cs])
        end
      | QFBV.Eunop op e1 =>
        let '(m1, c1, g1, cs1, ls1) := bit_blast_exp_fccache E m c g e1 in
        match find_het e c1 with
        | Some (csop, lsop) => (m1, c1, g1, catrev cs1 csop, lsop, csop)
        | None =>
          let '(gop, csop, lsop) := bit_blast_eunop op g1 ls1 in
          (m1, add_het e [:: csop] lsop c1, gop,
           catrev cs1 [:: csop], lsop, [:: csop])
        end
      | QFBV.Ebinop op e1 e2 =>
        let '(m1, c1, g1, cs1, ls1) := bit_blast_exp_fccache E m c g e1 in
        let '(m2, c2, g2, cs2, ls2) := bit_blast_exp_fccache E m1 c1 g1 e2 in
        match find_het e c2 with
        | Some (csop, lsop) => (m2, c2, g2, catrev cs1 (catrev cs2 csop), lsop, csop)
        | None =>
          let '(gop, csop, lsop) := bit_blast_ebinop op g2 ls1 ls2 in
          (m2, add_het e [:: csop] lsop c2, gop,
           catrev cs1 (catrev cs2 [:: csop]), lsop, [:: csop])
        end
      | QFBV.Eite b e1 e2 =>
        let '(mb, cb, gb, csb, lb) := bit_blast_bexp_fccache E m c g b in
        let '(m1, c1, g1, cs1, ls1) := bit_blast_exp_fccache E mb cb gb e1 in
        let '(m2, c2, g2, cs2, ls2) := bit_blast_exp_fccache E m1 c1 g1 e2 in
        match find_het e c2 with
        | Some (csop, lsop) =>
          (m2, c2, g2, catrev csb (catrev cs1 (catrev cs2 csop)), lsop, csop)
        | None =>
          let '(gop, csop, lsop) := bit_blast_ite g2 lb ls1 ls2 in
          (m2, add_het e [:: csop] lsop c2, gop,
           catrev csb (catrev cs1 (catrev cs2 [:: csop])), lsop, [:: csop])
        end
      end
  (* = = *)
  in
  match find_cet e c with
  | Some (cs, ls) => (m, c, g, [::], ls)
  | None => let '(m', c', g', cs, lrs, csop) := bit_blast_exp_nocet E m c g e in
            (m', CCacheFlatten.add_cet e csop lrs c', g', cs, lrs)
  end
with
bit_blast_bexp_fccache E m c g e : vm * ccache * generator * seq cnf * literal :=
  (* = bit_blast_bexp_nocbt = *)
  let bit_blast_bexp_nocbt E m c g e : vm * ccache * generator * seq cnf * literal * seq cnf :=
      match e with
      | QFBV.Bfalse =>
        match find_hbt e c with
        | Some (cs, l) => (m, c, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_ff c, g, [::], lit_ff, [::])
        end
      | QFBV.Btrue =>
        match find_hbt e c with
        | Some (cs, l) => (m, c, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_tt c, g, [::], lit_tt, [::])
        end
      | QFBV.Bbinop op e1 e2 =>
        let '(m1, c1, g1, cs1, ls1) := bit_blast_exp_fccache E m c g e1 in
        let '(m2, c2, g2, cs2, ls2) := bit_blast_exp_fccache E m1 c1 g1 e2 in
        match find_hbt e c2 with
        | Some (csop, lop) => (m2, c2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None =>
          let '(gop, csop, lop) := bit_blast_bbinop op g2 ls1 ls2 in
          (m2, add_hbt e [:: csop] lop c2, gop,
           catrev cs1 (catrev cs2 [:: csop]), lop, [:: csop])
        end
      | QFBV.Blneg e1 =>
        let '(m1, c1, g1, cs1, l1) := bit_blast_bexp_fccache E m c g e1 in
        match find_hbt e c1 with
        | Some (csop, lop) => (m1, c1, g1, catrev cs1 csop, lop, csop)
        | None => let '(gop, csop, lop) := bit_blast_lneg g1 l1 in
                  (m1, add_hbt e [:: csop] lop c1, gop,
                   catrev cs1 [:: csop], lop, [:: csop])
        end
      | QFBV.Bconj e1 e2 =>
        let '(m1, c1, g1, cs1, l1) := bit_blast_bexp_fccache E m c g e1 in
        let '(m2, c2, g2, cs2, l2) := bit_blast_bexp_fccache E m1 c1 g1 e2 in
        match find_hbt e c2 with
        | Some (csop, lop) => (m2, c2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(gop, csop, lop) := bit_blast_conj g2 l1 l2 in
                  (m2, add_hbt e [:: csop] lop c2, gop,
                   catrev cs1 (catrev cs2 [:: csop]), lop, [:: csop])
        end
      | QFBV.Bdisj e1 e2 =>
        let '(m1, c1, g1, cs1, l1) := bit_blast_bexp_fccache E m c g e1 in
        let '(m2, c2, g2, cs2, l2) := bit_blast_bexp_fccache E m1 c1 g1 e2 in
        match find_hbt e c2 with
        | Some (csop, lop) => (m2, c2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(gop, csop, lop) := bit_blast_disj g2 l1 l2 in
                  (m2, add_hbt e [:: csop] lop c2, gop,
                   catrev cs1 (catrev cs2 [:: csop]), lop, [:: csop])
        end
      end
  (* = = *)
  in
  match find_cbt e c with
  | Some (cs, l) => (m, c, g, [::], l)
  | None => let '(m', c', g', cs, lr, csop) := bit_blast_bexp_nocbt E m c g e in
            (m', CCacheFlatten.add_cbt e csop lr c', g', cs, lr)
  end.

Definition init_fccache : ccache := CCacheFlatten.empty.

Lemma init_fccache_compatible : ccache_compatible init_fccache init_ccache.
Proof. done. Qed.

Ltac dcase_bb_base :=
  match goal with
  | |- context f [bit_blast_var ?E ?g ?v] =>
    let g' := fresh in
    let cs := fresh in
    let lrs := fresh in
    let H := fresh in
    dcase (bit_blast_var E g v) => [[[g' cs] lrs] H]
  | |- context f [bit_blast_eunop ?op ?g ?lrs] =>
    let g' := fresh in
    let cs' := fresh in
    let lrs' := fresh in
    let H := fresh in
    dcase (bit_blast_eunop op g lrs) => [[[g' cs'] lrs'] H]
  | |- context f [bit_blast_ebinop ?op ?g ?lrs1 ?lrs2] =>
    let g' := fresh in
    let cs' := fresh in
    let lrs' := fresh in
    let H := fresh in
    dcase (bit_blast_ebinop op g lrs1 lrs2) => [[[g' cs'] lrs'] H]
  | |- context f [bit_blast_ite ?g ?lr ?ls1 ?ls2] =>
    let g' := fresh in
    let cs' := fresh in
    let lr' := fresh in
    let H := fresh in
    dcase (bit_blast_ite g lr ls1 ls2) => [[[g' cs'] lr'] H]
  | |- context f [bit_blast_bbinop ?op ?g ?lrs1 ?lrs2] =>
    let g' := fresh in
    let cs' := fresh in
    let lr' := fresh in
    let H := fresh in
    dcase (bit_blast_bbinop op g lrs1 lrs2) => [[[g' cs'] lr'] H]
  end.

Ltac dcase_bb_ccache :=
  match goal with
  | |- context f [find_cet ?e ?c] =>
    let Hfe_cet := fresh in
    let cs := fresh in
    let lrs := fresh in
    dcase (find_cet e c); case=> [[cs lrs]|] Hfe_cet
  | |- context f [find_cbt ?e ?c] =>
    let Hfe_cbt := fresh in
    let cs := fresh in
    let lr := fresh in
    dcase (find_cbt e c); case=> [[cs lr]|] Hfe_cbt
  | |- context f [find_het ?e ?c] =>
    let Hfe_het := fresh in
    let cs := fresh in
    let lrs := fresh in
    dcase (find_het e c); case=> [[cs lrs]|] Hfe_het
  | |- context f [find_hbt ?e ?c] =>
    let Hfe_hbt := fresh in
    let cs := fresh in
    let lr := fresh in
    dcase (find_hbt e c); case=> [[cs lr]|] Hfe_hbt
  (**)
  | |- context f [SSAVM.find ?v ?m] =>
    let lrs := fresh in
    case: (SSAVM.find v m) => [lrs|]
  | |- context f [bit_blast_exp_fccache ?E ?m ?ec ?g ?e] =>
    let m' := fresh in
    let ec' := fresh in
    let g' := fresh in
    let cs := fresh in
    let lrs := fresh in
    let H := fresh in
    dcase (bit_blast_exp_fccache E m ec g e) =>
    [[[[[m' ec'] g'] cs] lrs] H]
  | |- context f [bit_blast_bexp_fccache ?E ?m ?ec ?g ?e] =>
    let m' := fresh in
    let ec' := fresh in
    let g' := fresh in
    let cs := fresh in
    let lr := fresh in
    let H := fresh in
    dcase (bit_blast_bexp_fccache E m ec g e) =>
    [[[[[m' ec'] g'] cs] lr] H]
  | |- context f [bit_blast_exp_ccache ?E ?m ?c ?g ?e] =>
    let m' := fresh in
    let c' := fresh in
    let g' := fresh in
    let cs := fresh in
    let lrs := fresh in
    let H := fresh in
    dcase (bit_blast_exp_ccache E m c g e) =>
    [[[[[m' c'] g'] cs] lrs] H]
  | |- context f [bit_blast_bexp_ccache ?E ?m ?c ?g ?e] =>
    let m' := fresh in
    let c' := fresh in
    let g' := fresh in
    let cs := fresh in
    let lr := fresh in
    let H := fresh in
    dcase (bit_blast_bexp_ccache E m c g e) =>
    [[[[[m' c'] g'] cs] lr] H]
  (**)
  | |- _ => dcase_bb_base
  end.

Ltac simpl_ccache_compatible :=
  match goal with
  | |- ccache_compatible (add_cet ?e ?ecs ?lrs _) (CompCache.add_cet ?e ?cs ?lrs _) =>
    apply: ccache_compatible_add_cet
  | |- ccache_compatible (add_cbt ?e ?ecs ?lr _) (CompCache.add_cbt ?e ?cs ?lr _) =>
    apply: ccache_compatible_add_cbt
  | |- ccache_compatible (add_het ?e ?ecs ?lrs _) (CompCache.add_het ?e ?cs ?lrs _) =>
    apply: ccache_compatible_add_het
  | |- ccache_compatible (add_hbt ?e ?ecs ?lrs _) (CompCache.add_hbt ?e ?cs ?lrs _) =>
    apply: ccache_compatible_add_hbt
  | |- cnf_eqsat (tflatten [:: ?cs]) ?cs => exact: tflatten_singleton_eqsat
  | |- cnf_eqsat (tflatten (catrev _ _)) ?cs => apply: tflatten_catrev_eqsat
  | |- cnf_eqsat (tflatten [::]) [::] => done
  (**)
  | Hc : ccache_compatible ?ec ?c,
    H : find_cet ?e ?ec = None |- context f [CompCache.find_cet ?e ?c] =>
    move/(ccache_compatible_find_cet_none _ Hc): H => H; rewrite H
  | Hc : ccache_compatible ?ec ?c,
    H : find_cbt ?e ?ec = None |- context f [CompCache.find_cbt ?e ?c] =>
    move/(ccache_compatible_find_cbt_none _ Hc): H => H; rewrite H
  | Hc : ccache_compatible ?ec ?c,
    H : find_het ?e ?ec = None |- context f [CompCache.find_het ?e ?c] =>
    move/(ccache_compatible_find_het_none _ Hc): H => H; rewrite H
  | Hc : ccache_compatible ?ec ?c,
    H : find_hbt ?e ?ec = None |- context f [CompCache.find_hbt ?e ?c] =>
    move/(ccache_compatible_find_hbt_none _ Hc): H => H; rewrite H
  | Hc : ccache_compatible ?ec ?c,
    H : find_cet ?e ?ec = Some _ |- context f [CompCache.find_cet ?e ?c] =>
    let cs := fresh in
    let Hf_cet := fresh in
    let Heqs := fresh in
    let Heqn := fresh in
    move: (ccache_compatible_find_cet_some_exists1 Hc H) =>
    [cs [Hf_cet [Heqs Heqn]]]; rewrite Hf_cet
  | Hc : ccache_compatible ?ec ?c,
    H : find_cbt ?e ?ec = Some _ |- context f [CompCache.find_cbt ?e ?c] =>
    let cs := fresh in
    let Hf_cbt := fresh in
    let Heqs := fresh in
    let Heqn := fresh in
    move: (ccache_compatible_find_cbt_some_exists1 Hc H) =>
    [cs [Hf_cbt [Heqs Heqn]]]; rewrite Hf_cbt
  | Hc : ccache_compatible ?ec ?c,
    H : find_het ?e ?ec = Some _ |- context f [CompCache.find_het ?e ?c] =>
    let cs := fresh in
    let Hf_het := fresh in
    let Heqs := fresh in
    let Heqs := fresh in
    move: (ccache_compatible_find_het_some_exists1 Hc H) =>
    [cs [Hf_het [Heqs heqn]]]; rewrite Hf_het
  | Hc : ccache_compatible ?ec ?c,
    H : find_hbt ?e ?ec = Some _ |- context f [CompCache.find_hbt ?e ?c] =>
    let cs := fresh in
    let Hf_hbt := fresh in
    let Heqs := fresh in
    let Heqs := fresh in
    move: (ccache_compatible_find_hbt_some_exists1 Hc H) =>
    [cs [Hf_hbt [Heqs Heqn]]]; rewrite Hf_hbt
  end.

Ltac solve_eqnew :=
  match goal with
  | |- cnf_eqnew (tflatten [::]) [::] => done
  | |- cnf_eqnew (tflatten [:: ?cs]) ?cs => exact: tflatten_singleton_eqnew
  | H12 : cnf_eqnew (tflatten ?cs1) ?cs2
    |- cnf_eqnew (tflatten (catrev ?cs1 ?cs3)) (catrev ?cs2 ?cs4) =>
    apply: (cnf_eqnew_catrev2 H12)
  | H34 : cnf_eqnew (tflatten ?cs3) ?cs4
    |- cnf_eqnew (tflatten (catrev ?cs1 ?cs3)) (catrev ?cs2 ?cs4) =>
    apply: (cnf_eqnew_catrev2 _ H34)
  end.

Ltac myauto :=
  repeat
    match goal with
    | |- _ /\ _ => split
    | |- ?e = ?e => reflexivity
    | H : ?p |- ?p => assumption
    | |- (_, _, _, _, _) = (_, _, _, _, _) -> _ =>
      case=> ? ? ? ? ?; subst
    (* apply induction hypothesis *)
    | bit_blast_exp_fccache_valid :
        (forall (E : SSATE.env)
               (e : QFBV.exp) (im : vm)
               (iec : ccache) (ic : CompCache.compcache)
               (ig : generator) (em : vm)
               (ec : ccache) (eg : generator)
               (ecs : seq cnf) (elrs : word)
               (m : vm) (c : CompCache.compcache)
               (g : generator) (cs : cnf)
               (lrs : word),
            ccache_compatible iec ic ->
            bit_blast_exp_fccache E im iec ig e = (em, ec, eg, ecs, elrs) ->
            bit_blast_exp_ccache E im ic ig e =
            (m, c, g, cs, lrs) ->
            em = m /\
            ccache_compatible ec c /\
            eg = g /\ cnf_eqsat (tflatten ecs) cs /\ cnf_eqnew (tflatten ecs) cs /\ elrs = lrs),
      Hcc : ccache_compatible ?iec ?ic,
      Hbbe : bit_blast_exp_fccache ?E ?im ?iec ?ig ?e = _,
      Hbb : bit_blast_exp_ccache ?E ?im ?ic ?ig ?e = _ |- _ =>
      let Hm := fresh in
      let Hc := fresh in
      let Hg := fresh in
      let Hcs_eqs := fresh in
      let Hcs_eqn := fresh in
      let Hlrs:= fresh in
      move: (bit_blast_exp_fccache_valid
               _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hcc Hbbe Hbb);
      move=> [Hm [Hc [Hg [Hcs_eqs [Hcs_eqn Hlrs]]]]]; subst; clear Hbbe Hbb
    | bit_blast_bexp_fccache_valid :
        (forall (E : SSATE.env)
                (e : QFBV.bexp) (im : vm)
                (iec : ccache) (ic : CompCache.compcache)
                (ig : generator) (em : vm)
                (ec : ccache) (eg : generator)
                (ecs : seq cnf) (elr : literal)
                (m : vm) (c : CompCache.compcache)
                (g : generator) (cs : cnf)
                (lr : literal),
            ccache_compatible iec ic ->
            bit_blast_bexp_fccache E im iec ig e = (em, ec, eg, ecs, elr) ->
            bit_blast_bexp_ccache E im ic ig e = (m, c, g, cs, lr) ->
            em = m /\
            ccache_compatible ec c /\
            eg = g /\ cnf_eqsat (tflatten ecs) cs /\ cnf_eqnew (tflatten ecs) cs /\ elr = lr),
      Hcc : ccache_compatible ?iec ?ic,
      Hbbe : bit_blast_bexp_fccache ?E ?im ?iec ?ig ?e = _,
      Hbb : bit_blast_bexp_ccache ?E ?im ?ic ?ig ?e = _ |- _ =>
      let Hm := fresh in
      let Hc := fresh in
      let Hg := fresh in
      let Hcs_eqs := fresh in
      let Hcs_eqn := fresh in
      let Hlr:= fresh in
      move: (bit_blast_bexp_fccache_valid
               _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hcc Hbbe Hbb);
      move=> [Hm [Hc [Hg [Hcs_eqs [Hcs_eqn Hlr]]]]]; subst; clear Hbbe Hbb
    (**)
    | |- _ => simpl_ccache_compatible || dcase_bb_ccache || solve_eqnew
    end.

Lemma bit_blast_exp_fccache_valid
      E e im iec ic ig em ec eg ecs elrs m c g cs lrs :
  ccache_compatible iec ic ->
  bit_blast_exp_fccache E im iec ig e = (em, ec, eg, ecs, elrs) ->
  bit_blast_exp_ccache E im ic ig e = (m, c, g, cs, lrs) ->
  em = m
  /\ ccache_compatible ec c
  /\ eg = g
  /\ cnf_eqsat (tflatten ecs) cs
  /\ cnf_eqnew (tflatten ecs) cs
  /\ elrs = lrs
with
bit_blast_bexp_fccache_valid E e im iec ic ig em ec eg ecs elr m c g cs lr :
  ccache_compatible iec ic ->
  bit_blast_bexp_fccache E im iec ig e = (em, ec, eg, ecs, elr) ->
  bit_blast_bexp_ccache E im ic ig e = (m, c, g, cs, lr) ->
  em = m
  /\ ccache_compatible ec c
  /\ eg = g
  /\ cnf_eqsat (tflatten ecs) cs
  /\ cnf_eqnew (tflatten ecs) cs
  /\ elr = lr.
Proof.
  (* bit_blast_exp_fccache_valid *)
  move=> Hcc. case: e => /=.
  - move=> v. by myauto.
  - move=> bs. by myauto.
  - move=> op e. by myauto.
  - move=> op e1 e2. by myauto.
  - move=> e1 e2 e3. by myauto.
  (* bit_blast_bexp_fccache_valid *)
  move=> Hcc. case: e => /=.
  - by myauto.
  - by myauto.
  - move=> op e1 e2. by myauto.
  - move=> e. by myauto.
  - move=> e1 e2. by myauto.
  - move=> e1 e2. by myauto.
Qed.

Theorem bit_blast_bexp_fccache_sound E e m c g cs lr :
  bit_blast_bexp_fccache
    E init_vm init_fccache init_gen e = (m, c, g, cs, lr) ->
  QFBV.well_formed_bexp e E ->
  ~ (sat (add_prelude ([::neg_lit lr]::(tflatten cs)))) ->
  (forall s, AdhereConform.conform_bexp e s E ->
             QFBV.eval_bexp e s).
Proof.
  move=> Hbbe Hwf Hsat.
  dcase (bit_blast_bexp_ccache E init_vm init_ccache init_gen e) =>
  [[[[[m' c'] g'] cs'] lr'] Hbb].
  move: (bit_blast_bexp_fccache_valid
           (init_fccache_compatible) Hbbe Hbb) => [Hm [Hcc [Hg [Heqs [Heqn Hlr]]]]]; subst.
  apply: (bit_blast_ccache_sound Hbb Hwf). move=> Hs. apply: Hsat.
  move: (cnf_eqsat_cons (clause_eqsat_refl [:: neg_lit lr']) Heqs) => Heqs'.
  apply/(cnf_eqsat_add_prelude_sat Heqs'). assumption.
Qed.

Theorem bit_blast_bexp_fccache_complete E e m c g cs lr :
  bit_blast_bexp_fccache E init_vm init_fccache init_gen e = (m, c, g, cs, lr) ->
  QFBV.well_formed_bexp e E ->
  (forall s, AdhereConform.conform_bexp e s E ->
             QFBV.eval_bexp e s) ->
  ~ (sat (add_prelude ([::neg_lit lr]::(tflatten cs)))).
Proof.
  move=> Hbbe Hwf Hev.
  dcase (bit_blast_bexp_ccache E init_vm init_ccache init_gen e) =>
  [[[[[m' c'] g'] cs'] lr'] Hbb].
  move: (bit_blast_bexp_fccache_valid
           (init_fccache_compatible) Hbbe Hbb) => [Hm [Hcc [Hg [Heqs [Heqn Hlr]]]]]; subst.
  move=> Hs. move: (cnf_eqsat_cons (clause_eqsat_refl [:: neg_lit lr']) Heqs) => Heqs'.
  move/(cnf_eqsat_add_prelude_sat Heqs'): Hs => {Heqs'}.
  exact: (bit_blast_ccache_complete Hbb Hwf Hev).
Qed.

Theorem bit_blast_bexp_fccache_sat_sound E e m c g cs lr :
  bit_blast_bexp_fccache
    E init_vm init_fccache init_gen e = (m, c, g, cs, lr) ->
  QFBV.well_formed_bexp e E ->
  (sat (add_prelude ([::lr]::(tflatten cs)))) ->
  (exists s, AdhereConform.conform_bexp e s E /\
             QFBV.eval_bexp e s).
Proof.
  move=> Hbbe Hwf Hsat.
  dcase (bit_blast_bexp_ccache E init_vm init_ccache init_gen e) =>
  [[[[[m' c'] g'] cs'] lr'] Hbb].
  move: (bit_blast_bexp_fccache_valid
           (init_fccache_compatible) Hbbe Hbb) => [Hm [Hcc [Hg [Heqs [Heqn Hlr]]]]]; subst.
  apply: (bit_blast_ccache_sat_sound Hbb Hwf).
  move: (cnf_eqsat_cons (clause_eqsat_refl [:: lr']) Heqs) => Heqs'.
  apply/(cnf_eqsat_add_prelude_sat Heqs'). assumption.
Qed.

Theorem bit_blast_bexp_fccache_sat_complete E e m c g cs lr :
  bit_blast_bexp_fccache E init_vm init_fccache init_gen e = (m, c, g, cs, lr) ->
  QFBV.well_formed_bexp e E ->
  (exists s, AdhereConform.conform_bexp e s E /\
             QFBV.eval_bexp e s) ->
  (sat (add_prelude ([::lr]::(tflatten cs)))).
Proof.
  move=> Hbbe Hwf Hev.
  dcase (bit_blast_bexp_ccache E init_vm init_ccache init_gen e) =>
  [[[[[m' c'] g'] cs'] lr'] Hbb].
  move: (bit_blast_bexp_fccache_valid
           (init_fccache_compatible) Hbbe Hbb) => [Hm [Hcc [Hg [Heqs [Heqn Hlr]]]]]; subst.
  move: (cnf_eqsat_cons (clause_eqsat_refl [:: lr']) Heqs) => Heqs'.
  apply/(cnf_eqsat_add_prelude_sat Heqs').
  exact: (bit_blast_ccache_sat_complete Hbb Hwf Hev).
Qed.

(* ==== general case ==== *)

(* = bit-blasting multiple bexps = *)

Definition bit_blast_bexp_fccache_tflatten E m c g e :=
  let '(m', c', g', css', lr') := bit_blast_bexp_fccache E m c g e in
  (m', c', g', tflatten css', lr').

Fixpoint bit_blast_bexps_fccache E (es : seq QFBV.bexp) :=
  match es with
  | [::] => (init_vm, init_fccache, init_gen, add_prelude [::], lit_tt)
  | e :: es' =>
    let '(m, c, g, cs, lr) := bit_blast_bexps_fccache E es' in
    bit_blast_bexp_fccache_tflatten E m (CCacheFlatten.reset_ct c) g e
  end.

Lemma bit_blast_bexps_fccache_valid E es m c g cs lr m' c' g' cs' lr' :
  bit_blast_bexps_fccache E es = (m, c, g, cs, lr) ->
  bit_blast_bexps_ccache E es = (m', c', g', cs', lr') ->
  m = m' /\ ccache_compatible c c' /\ g = g' /\ cnf_eqsat cs cs' /\ cnf_eqnew cs cs' /\ lr = lr'.
Proof.
  elim: es m c g cs lr m' c' g' cs' lr' => [| e es IH] m c g cs lr m' c' g' cs' lr' /=.
  - move=> [] ? ? ? ? ? [] ? ? ? ? ?; subst. done.
  - dcase (bit_blast_bexps_fccache E es) => [[[[[m1 c1] g1] cs1] lr1] Hbbe1].
    move=> Hbbe2.
    dcase (bit_blast_bexps_ccache E es) => [[[[[m1' c1'] g1'] cs1'] lr1'] Hbb1].
    move=> Hbb2. move: (IH _ _ _ _ _ _ _ _ _ _ Hbbe1 Hbb1).
    move=> [Hn [Hc [Hg [Heqs [Heqn Hlr]]]]]; subst.
    move: Hbbe2. rewrite /bit_blast_bexp_fccache_tflatten.
    dcase (bit_blast_bexp_fccache E m1' (reset_ct c1) g1' e) =>
    [[[[[m'' c''] g''] cs''] lrs''] Hbbe1']. case=> ? ? ? ? ?; subst.
    exact: (bit_blast_bexp_fccache_valid (ccache_compatible_reset_ct Hc)
                                           Hbbe1' Hbb2).
Qed.

Theorem bit_blast_bexps_fccache_sound e es E m c g cs lr :
  bit_blast_bexps_fccache E (e::es) = (m, c, g, cs, lr) ->
  QFBV.well_formed_bexps (e::es) E ->
  ~ (sat (add_prelude ([::neg_lit lr]::cs))) ->
  (forall s, AdhereConform.conform_bexps (e::es) s E ->
             QFBV.eval_bexp e s).
Proof.
  move=> Hbbe Hwf Hsat.
  dcase (bit_blast_bexps_ccache E (e::es)) => [[[[[m' c'] g'] cs'] lr'] Hbb].
  move: (bit_blast_bexps_fccache_valid Hbbe Hbb).
  move=> [Hm [Hc [Hg [Heqs [Heqn Hlr]]]]]; subst.
  have Hsat': ~ sat (add_prelude ([:: neg_lit lr'] :: cs')).
  { move=> H. apply: Hsat.
    move: (cnf_eqsat_cons (clause_eqsat_refl [:: neg_lit lr']) Heqs) => Heqs'.
    apply/(cnf_eqsat_add_prelude_sat Heqs'). assumption. }
  exact: (bit_blast_ccache_sound_general Hbb Hwf Hsat').
Qed.

Theorem bit_blast_bexps_fccache_complete e es E m c g cs lr :
  bit_blast_bexps_fccache E (e::es) = (m, c, g, cs, lr) ->
  QFBV.well_formed_bexps (e::es) E ->
  (forall s, AdhereConform.conform_bexps (e::es) s E ->
             QFBV.eval_bexp e s) ->
  ~ (sat (add_prelude ([::neg_lit lr]::cs))).
Proof.
  move=> Hbbe Hwf Hev Hsat.
  dcase (bit_blast_bexps_ccache E (e::es)) => [[[[[m' c'] g'] cs'] lr'] Hbb].
  move: (bit_blast_bexps_fccache_valid Hbbe Hbb).
  move=> [Hm [Hc [Hg [Heqs [Heqn Hlr]]]]]; subst.
  have Hsat': sat (add_prelude ([:: neg_lit lr'] :: cs')).
  { move: (cnf_eqsat_cons (clause_eqsat_refl [:: neg_lit lr']) Heqs) => Heqs'.
    apply/(cnf_eqsat_add_prelude_sat Heqs'). assumption. }
  move: Hsat'. exact: (bit_blast_ccache_complete_general Hbb Hwf Hev).
Qed.

Definition bexp_to_cnf_fccache E m c g e :=
  let '(m', c', g', cs, lr) := bit_blast_bexp_fccache_tflatten E m c g e in
  (m', c', g', add_prelude ([::neg_lit lr]::cs)).

(* ===== mk_env_exp_fccache and mk_env_bexp_fccache ===== *)

Fixpoint mk_env_exp_fccache E s m c g e : env * vm * ccache * generator * seq cnf * word :=
  (* = bit_blast_exp_nocet = *)
  let mk_env_exp_nocet E s m c g e : env * vm * ccache * generator * seq cnf * word * seq cnf :=
      match e with
      | QFBV.Evar v =>
        match find_het e c with
        | Some (cs, ls) => (E, m, c, g, cs, ls, cs)
        | None =>
          match SSAVM.find v m with
          | None => let '(E', g', cs, rs) := mk_env_var E g (SSAStore.acc v s) v in
                    (E', SSAVM.add v rs m, add_het e [:: cs] rs c, g', [:: cs], rs, [:: cs])
          | Some rs => (E, m, add_het e [::] rs c, g, [::], rs, [::])
          end
        end
      | QFBV.Econst bs =>
        match find_het e c with
        | Some (cs, ls) => (E, m, c, g, cs, ls, cs)
        | None => let '(E', g', cs, rs) := mk_env_const E g bs in
                  (E', m, add_het e [:: cs] rs c, g', [:: cs], rs, [:: cs])
        end
      | QFBV.Eunop op e1 =>
        let '(E1, m1, c1, g1, cs1, ls1) := mk_env_exp_fccache E s m c g e1 in
        match find_het e c1 with
        | Some (csop, lsop) => (E1, m1, c1, g1, catrev cs1 csop, lsop, csop)
        | None =>
          let '(Eop, gop, csop, lsop) := mk_env_eunop op E1 g1 ls1 in
          (Eop, m1, add_het e [:: csop] lsop c1, gop,
           catrev cs1 [:: csop], lsop, [:: csop])
        end
      | QFBV.Ebinop op e1 e2 =>
        let '(E1, m1, c1, g1, cs1, ls1) := mk_env_exp_fccache E s m c g e1 in
        let '(E2, m2, c2, g2, cs2, ls2) := mk_env_exp_fccache E1 s m1 c1 g1 e2 in
        match find_het e c2 with
        | Some (csop, lsop) => (E2, m2, c2, g2, catrev cs1 (catrev cs2 csop), lsop, csop)
        | None =>
          let '(Eop, gop, csop, lsop) := mk_env_ebinop op E2 g2 ls1 ls2 in
          (Eop, m2, add_het e [:: csop] lsop c2, gop,
           catrev cs1 (catrev cs2 [:: csop]), lsop, [:: csop])
        end
      | QFBV.Eite b e1 e2 =>
        let '(Eb, mb, cb, gb, csb, lb) := mk_env_bexp_fccache E s m c g b in
        let '(E1, m1, c1, g1, cs1, ls1) := mk_env_exp_fccache Eb s mb cb gb e1 in
        let '(E2, m2, c2, g2, cs2, ls2) := mk_env_exp_fccache E1 s m1 c1 g1 e2 in
        match find_het e c2 with
        | Some (csop, lsop) =>
          (E2, m2, c2, g2, catrev csb (catrev cs1 (catrev cs2 csop)), lsop, csop)
        | None =>
          let '(Eop, gop, csop, lsop) := mk_env_ite E2 g2 lb ls1 ls2 in
          (Eop, m2, add_het e [:: csop] lsop c2, gop,
           catrev csb (catrev cs1 (catrev cs2 [:: csop])), lsop, [:: csop])
        end
      end
  (* = = *)
  in
  match find_cet e c with
  | Some (cs, ls) => (E, m, c, g, [::], ls)
  | None => let '(E', m', c', g', cs, lrs, csop) := mk_env_exp_nocet E s m c g e in
            (E', m', CCacheFlatten.add_cet e csop lrs c', g', cs, lrs)
  end
with
mk_env_bexp_fccache E s m c g e : env * vm * ccache * generator * seq cnf * literal :=
  (* = bit_blast_bexp_nocbt = *)
  let mk_env_bexp_nocbt E s m c g e : env * vm * ccache * generator * seq cnf * literal * seq cnf :=
      match e with
      | QFBV.Bfalse =>
        match find_hbt e c with
        | Some (cs, l) => (E, m, c, g, cs, l, cs)
        | None => (E, m, add_hbt e [::] lit_ff c, g, [::], lit_ff, [::])
        end
      | QFBV.Btrue =>
        match find_hbt e c with
        | Some (cs, l) => (E, m, c, g, cs, l, cs)
        | None => (E, m, add_hbt e [::] lit_tt c, g, [::], lit_tt, [::])
        end
      | QFBV.Bbinop op e1 e2 =>
        let '(E1, m1, c1, g1, cs1, ls1) := mk_env_exp_fccache E s m c g e1 in
        let '(E2, m2, c2, g2, cs2, ls2) := mk_env_exp_fccache E1 s m1 c1 g1 e2 in
        match find_hbt e c2 with
        | Some (csop, lop) => (E2, m2, c2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None =>
          let '(Eop, gop, csop, lop) := mk_env_bbinop op E2 g2 ls1 ls2 in
          (Eop, m2, add_hbt e [:: csop] lop c2, gop,
           catrev cs1 (catrev cs2 [:: csop]), lop, [:: csop])
        end
      | QFBV.Blneg e1 =>
        let '(E1, m1, c1, g1, cs1, l1) := mk_env_bexp_fccache E s m c g e1 in
        match find_hbt e c1 with
        | Some (csop, lop) => (E1, m1, c1, g1, catrev cs1 csop, lop, csop)
        | None => let '(Eop, gop, csop, lop) := mk_env_lneg E1 g1 l1 in
                  (Eop, m1, add_hbt e [:: csop] lop c1, gop,
                   catrev cs1 [:: csop], lop, [:: csop])
        end
      | QFBV.Bconj e1 e2 =>
        let '(E1, m1, c1, g1, cs1, l1) := mk_env_bexp_fccache E s m c g e1 in
        let '(E2, m2, c2, g2, cs2, l2) := mk_env_bexp_fccache E1 s m1 c1 g1 e2 in
        match find_hbt e c2 with
        | Some (csop, lop) => (E2, m2, c2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(Eop, gop, csop, lop) := mk_env_conj E2 g2 l1 l2 in
                  (Eop, m2, add_hbt e [:: csop] lop c2, gop,
                   catrev cs1 (catrev cs2 [:: csop]), lop, [:: csop])
        end
      | QFBV.Bdisj e1 e2 =>
        let '(E1, m1, c1, g1, cs1, l1) := mk_env_bexp_fccache E s m c g e1 in
        let '(E2, m2, c2, g2, cs2, l2) := mk_env_bexp_fccache E1 s m1 c1 g1 e2 in
        match find_hbt e c2 with
        | Some (csop, lop) => (E2, m2, c2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(Eop, gop, csop, lop) := mk_env_disj E2 g2 l1 l2 in
                  (Eop, m2, add_hbt e [:: csop] lop c2, gop,
                   catrev cs1 (catrev cs2 [:: csop]), lop, [:: csop])
        end
      end
  (* = = *)
  in
  match find_cbt e c with
  | Some (cs, l) => (E, m, c, g, [::], l)
  | None => let '(E', m', c', g', cs, lr, csop) := mk_env_bexp_nocbt E s m c g e in
            (E', m', CCacheFlatten.add_cbt e csop lr c', g', cs, lr)
  end.

Ltac dcase_mk_env_ccache :=
  match goal with
  (**)
  | |- context f [SSAVM.find ?v ?m] =>
    let lrs := fresh in
    case: (SSAVM.find v m) => [lrs|]
  | |- context f [mk_env_exp_fccache ?E ?s ?m ?ec ?g ?e] =>
    let E' := fresh in
    let m' := fresh in
    let ec' := fresh in
    let g' := fresh in
    let cs := fresh in
    let lrs := fresh in
    let H := fresh in
    dcase (mk_env_exp_fccache E s m ec g e) =>
    [[[[[[E' m'] ec'] g'] cs] lrs] H]
  | |- context f [mk_env_bexp_fccache ?E ?s ?m ?ec ?g ?e] =>
    let E' := fresh in
    let m' := fresh in
    let ec' := fresh in
    let g' := fresh in
    let cs := fresh in
    let lr := fresh in
    let H := fresh in
    dcase (mk_env_bexp_fccache E s m ec g e) =>
    [[[[[[E' m'] ec'] g'] cs] lr] H]
  | |- context f [mk_env_exp_ccache ?m ?c ?s ?E ?g ?e] =>
    let m' := fresh in
    let c' := fresh in
    let E' := fresh in
    let g' := fresh in
    let cs := fresh in
    let lrs := fresh in
    let H := fresh in
    dcase (mk_env_exp_ccache m c s E g e) =>
    [[[[[[m' c'] E'] g'] cs] lrs] H]
  | |- context f [mk_env_bexp_ccache ?m ?c ?s ?E ?g ?e] =>
    let m' := fresh in
    let c' := fresh in
    let E' := fresh in
    let g' := fresh in
    let cs := fresh in
    let lr := fresh in
    let H := fresh in
    dcase (mk_env_bexp_ccache m c s E g e) =>
    [[[[[[m' c'] E'] g'] cs] lr] H]
  (**)
  | |- context f [mk_env_var ?E ?g ?ls ?v] =>
    let E' := fresh in
    let g' := fresh in
    let cs := fresh in
    let lrs := fresh in
    let H := fresh in
    dcase (mk_env_var E g ls v) => [[[[E' g'] cs] lrs] H]
  | |- context f [mk_env_eunop ?op ?E ?g ?lrs] =>
    let E' := fresh in
    let g' := fresh in
    let cs' := fresh in
    let lrs' := fresh in
    let H := fresh in
    dcase (mk_env_eunop op E g lrs) => [[[[E' g'] cs'] lrs'] H]
  | |- context f [mk_env_ebinop ?op ?E ?g ?lrs1 ?lrs2] =>
    let E' := fresh in
    let g' := fresh in
    let cs' := fresh in
    let lrs' := fresh in
    let H := fresh in
    dcase (mk_env_ebinop op E g lrs1 lrs2) => [[[[E' g'] cs'] lrs'] H]
  | |- context f [mk_env_ite ?E ?g ?lr ?ls1 ?ls2] =>
    let E' := fresh in
    let g' := fresh in
    let cs' := fresh in
    let lr' := fresh in
    let H := fresh in
    dcase (mk_env_ite E g lr ls1 ls2) => [[[[E' g'] cs'] lr'] H]
  | |- context f [mk_env_bbinop ?op ?E ?g ?lrs1 ?lrs2] =>
    let E' := fresh in
    let g' := fresh in
    let cs' := fresh in
    let lr' := fresh in
    let H := fresh in
    dcase (mk_env_bbinop op E g lrs1 lrs2) => [[[[E' g'] cs'] lr'] H]
  end.

Ltac myauto ::=
  repeat
    match goal with
    | |- _ /\ _ => split
    | |- ?e = ?e => reflexivity
    | H : ?p |- ?p => assumption
    | |- (_, _, _, _, _, _) = (_, _, _, _, _, _) -> _ =>
      case=> ? ? ? ? ? ?; subst
    | |- (_, _, _, _, _) = (_, _, _, _, _) -> _ =>
      case=> ? ? ? ? ?; subst
    | H1 : ?e = Some _, H2 : ?e = None |- _ =>
      rewrite H1 in H2; discriminate
    (**)
    | Hs : is_true (SSATE.vsize ?v ?TE == size ?bs),
           Henv : mk_env_var ?iE ?ig ?bs ?v = (?oE, ?og, ?ocs, ?olrs),
                  Hbb : bit_blast_var ?TE ?ig ?v = _ |- _ =>
      let Hbb' := fresh in
      rewrite eq_sym in Hs;
      (move: (mk_env_var_is_bit_blast_var (eqP Hs) Henv) => Hbb');
      rewrite Hbb in Hbb'; case: Hbb' => ? ? ?; subst
    | H1 : find_het ?e ?c = Some (?cs1, ?lrs1),
      H2 : find_het ?e ?c = Some (?cs2, ?lrs2) |- _ =>
      rewrite H1 in H2; case: H2 => ? ?; subst
    | H1 : find_hbt ?e ?c = Some (?cs1, ?lr1),
      H2 : find_hbt ?e ?c = Some (?cs2, ?lr2) |- _ =>
      rewrite H1 in H2; case: H2 => ? ?; subst
    | H1 : bit_blast_exp_fccache ?E ?m ?c ?g ?e = (?m1, ?c1, ?g1, ?cs1, ?lrs1),
      H2 : bit_blast_exp_fccache ?E ?m ?c ?g ?e = (?m2, ?c2, ?g2, ?cs2, ?lrs2) |- _ =>
      rewrite H1 in H2; case: H2 => ? ? ? ? ?; subst
    | H1 : bit_blast_bexp_fccache ?E ?m ?c ?g ?e = (?m1, ?c1, ?g1, ?cs1, ?lr1),
      H2 : bit_blast_bexp_fccache ?E ?m ?c ?g ?e = (?m2, ?c2, ?g2, ?cs2, ?lr2) |- _ =>
      rewrite H1 in H2; case: H2 => ? ? ? ? ?; subst
    | H1 : mk_env_eunop ?op ?E ?g ?ls = _,
      H2 : bit_blast_eunop ?op ?g ?ls = _ |- _ =>
      let H := fresh in
      (move: (mk_env_eunop_is_bit_blast_eunop H1) => H); rewrite H2 in H;
      case: H => ? ? ?; subst
    | H1 : mk_env_ebinop ?op ?E ?g ?ls1 ?ls2 = _,
      H2 : bit_blast_ebinop ?op ?g ?ls1 ?ls2 = _ |- _ =>
      let H := fresh in
      (move: (mk_env_ebinop_is_bit_blast_ebinop H1) => H); rewrite H2 in H;
      case: H => ? ? ?; subst
    | H1 : mk_env_bbinop ?op ?E ?g ?ls1 ?ls2 = _,
      H2 : bit_blast_bbinop ?op ?g ?ls1 ?ls2 = _ |- _ =>
      let H := fresh in
      (move: (mk_env_bbinop_is_bit_blast_bbinop H1) => H); rewrite H2 in H;
      case: H => ? ? ?; subst
    | H1 : mk_env_ite ?E ?g ?lc ?ls1 ?ls2 = _,
      H2 : bit_blast_ite ?g ?lc ?ls1 ?ls2 = _ |- _ =>
      let H := fresh in
      (move: (mk_env_ite_is_bit_blast_ite H1) => H); rewrite H2 in H;
      case: H => ? ? ?; subst
    (* apply induction hypothesis *)
    | mk_env_exp_fccache_is_bit_blast_exp_fccache :
        (forall (e : QFBV.exp)
                (s : SSAStore.t)
                (TE : SSATE.env)
                (iE : env) (im : vm)
                (ic : ccache) (ig : generator)
                (oE : env) (om : vm)
                (oc : ccache) (og : generator)
                (ocs : seq cnf)
                (olrs : word),
            is_true (AdhereConform.conform_exp e s TE) ->
            is_true (QFBV.well_formed_exp e TE) ->
            mk_env_exp_fccache iE s im ic ig e =
            (oE, om, oc, og, ocs, olrs) ->
            bit_blast_exp_fccache TE im ic ig e =
            (om, oc, og, ocs, olrs)),
        Hco : is_true (AdhereConform.conform_exp ?e ?s ?TE),
        Hwf : is_true (QFBV.well_formed_exp ?e ?TE),
        Henv : mk_env_exp_fccache ?iE ?s ?im ?ic ?ig ?e = _ |- _ =>
      let H := fresh "H" in
      (move: (mk_env_exp_fccache_is_bit_blast_exp_fccache _ _ _ _ _ _ _ _ _ _ _ _ _
                                                          Hco Hwf Henv) => H);
      clear Henv
    | mk_env_bexp_fccache_is_bit_blast_bexp_fccache :
        (forall (e : QFBV.bexp)
                (s : SSAStore.t)
                (TE : SSATE.env)
                (iE : env) (im : vm)
                (ic : ccache) (ig : generator)
                (oE : env) (om : vm)
                (oc : ccache) (og : generator)
                (ocs : seq cnf)
                (olr : literal),
            is_true (AdhereConform.conform_bexp e s TE) ->
            is_true (QFBV.well_formed_bexp e TE) ->
            mk_env_bexp_fccache iE s im ic ig e =
            (oE, om, oc, og, ocs, olr) ->
            bit_blast_bexp_fccache TE im ic ig e =
            (om, oc, og, ocs, olr)),
        Hco : is_true (AdhereConform.conform_bexp ?e ?s ?TE),
        Hwf : is_true (QFBV.well_formed_bexp ?e ?TE),
        Henv : mk_env_bexp_fccache ?iE ?s ?im ?ic ?ig ?e = _ |- _ =>
      let H := fresh "H" in
      (move: (mk_env_bexp_fccache_is_bit_blast_bexp_fccache _ _ _ _ _ _ _ _ _ _ _ _ _
                                                            Hco Hwf Henv) => H);
      clear Henv
    | |- _ => dcase_bb_ccache || dcase_mk_env_ccache
    end.

Lemma mk_env_exp_fccache_is_bit_blast_exp_fccache
      e s TE iE im ic ig oE om oc og ocs olrs :
  AdhereConform.conform_exp e s TE ->
  QFBV.well_formed_exp e TE ->
  mk_env_exp_fccache iE s im ic ig e = (oE, om, oc, og, ocs, olrs) ->
  bit_blast_exp_fccache TE im ic ig e = (om, oc, og, ocs, olrs)
with
mk_env_bexp_fccache_is_bit_blast_bexp_fccache
      e s TE iE im ic ig oE om oc og ocs olr :
  AdhereConform.conform_bexp e s TE ->
  QFBV.well_formed_bexp e TE ->
  mk_env_bexp_fccache iE s im ic ig e = (oE, om, oc, og, ocs, olr) ->
  bit_blast_bexp_fccache TE im ic ig e = (om, oc, og, ocs, olr).
Proof.
  (* mk_env_exp_fccache_is_bit_blast_exp_fccache *)
  case: e => //=.
  - move=> v Hs Hm. by myauto.
  - move=> bs _ _. by myauto.
  - move=> op e Hco Hwf. by myauto.
  - move=> op e1 e2 /andP [Hco1 Hco2] /andP [/andP [/andP [Hwf1 Hwf2] Hwfs1] Hwfs2].
    by myauto.
  - move=> e1 e2 e3 /andP [/andP [Hco1 Hco2] Hco3] /andP [/andP [/andP [Hwf1 Hwf2] Hwf3] Hwfs].
    by myauto.
  (* mk_env_bexp_fccache_is_bit_blast_bexp_fccache *)
  case: e => //=.
  - move=> _ _. by myauto.
  - move=> _ _. by myauto.
  - move=> op e1 e2 /andP [Hco1 Hco2] /andP [/andP [Hwf1 Hwf2] Hwfs]. by myauto.
  - move=> e Hco Hwf. by myauto.
  - move=> e1 e2 /andP [Hco1 Hco2] /andP [Hwf1 Hwf2]. by myauto.
  - move=> e1 e2 /andP [Hco1 Hco2] /andP [Hwf1 Hwf2]. by myauto.
Qed.

Ltac dcase_mk_env_compcache :=
  match goal with
  | |- context f [CompCache.find_cet ?e ?c] =>
    let Hfe_cet := fresh in
    let cs := fresh in
    let lrs := fresh in
    dcase (CompCache.find_cet e c); case=> [[cs lrs]|] Hfe_cet
  | |- context f [CompCache.find_cbt ?e ?c] =>
    let Hfe_cbt := fresh in
    let cs := fresh in
    let lr := fresh in
    dcase (CompCache.find_cbt e c); case=> [[cs lr]|] Hfe_cbt
  | |- context f [CompCache.find_het ?e ?c] =>
    let Hfe_het := fresh in
    let cs := fresh in
    let lrs := fresh in
    dcase (CompCache.find_het e c); case=> [[cs lrs]|] Hfe_het
  | |- context f [CompCache.find_hbt ?e ?c] =>
    let Hfe_hbt := fresh in
    let cs := fresh in
    let lr := fresh in
    dcase (CompCache.find_hbt e c); case=> [[cs lr]|] Hfe_hbt
  end.

Ltac simpl_ccache_compatible_find :=
  match goal with
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_cet ?e ?fc = Some (?fcs, ?flrs),
    Hf : CompCache.find_cet ?e ?c = Some (?cs, ?lrs) |- _ =>
    let Heqs := fresh in
    let Heqn := fresh in
    let Hlrs := fresh in
    (move: (ccache_compatible_find_cet_some Hcc Hff Hf) => [Heqs [Heqn Hlrs]]); subst;
    clear Hff; clear Hf
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_cbt ?e ?fc = Some (?fcs, ?flrs),
    Hf : CompCache.find_cbt ?e ?c = Some (?cs, ?lrs) |- _ =>
    let Heqs := fresh in
    let Heqn := fresh in
    let Hlrs := fresh in
    (move: (ccache_compatible_find_cbt_some Hcc Hff Hf) => [Heqs [Heqn Hlrs]]); subst;
    clear Hff; clear Hf
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_het ?e ?fc = Some (?fcs, ?flrs),
    Hf : CompCache.find_het ?e ?c = Some (?cs, ?lrs) |- _ =>
    let Heqs := fresh in
    let Heqn := fresh in
    let Hlrs := fresh in
    (move: (ccache_compatible_find_het_some Hcc Hff Hf) => [Heqs [Heqn Hlrs]]); subst;
    clear Hff; clear Hf
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_hbt ?e ?fc = Some (?fcs, ?flrs),
    Hf : CompCache.find_hbt ?e ?c = Some (?cs, ?lrs) |- _ =>
    let Heqs := fresh in
    let Heqn := fresh in
    let Hlrs := fresh in
    (move: (ccache_compatible_find_hbt_some Hcc Hff Hf) => [Heqs [Heqn Hlrs]]); subst;
    clear Hff; clear Hf
  (**)
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_cet ?e ?fc = Some _,
    Hf : CompCache.find_cet ?e ?c = None |- _ =>
    (move/(ccache_compatible_find_cet_none _ Hcc): Hf => Hf);
    rewrite Hff in Hf; discriminate
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_cbt ?e ?fc = Some _,
    Hf : CompCache.find_cbt ?e ?c = None |- _ =>
    (move/(ccache_compatible_find_cbt_none _ Hcc): Hf => Hf);
    rewrite Hff in Hf; discriminate
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_het ?e ?fc = Some _,
    Hf : CompCache.find_het ?e ?c = None |- _ =>
    (move/(ccache_compatible_find_het_none _ Hcc): Hf => Hf);
    rewrite Hff in Hf; discriminate
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_hbt ?e ?fc = Some _,
    Hf : CompCache.find_hbt ?e ?c = None |- _ =>
    (move/(ccache_compatible_find_hbt_none _ Hcc): Hf => Hf);
    rewrite Hff in Hf; discriminate
  (**)
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_cet ?e ?fc = None,
    Hf : CompCache.find_cet ?e ?c = Some _ |- _ =>
    (move/(ccache_compatible_find_cet_none _ Hcc): Hff => Hff);
    rewrite Hf in Hff; discriminate
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_cbt ?e ?fc = None,
    Hf : CompCache.find_cbt ?e ?c = Some _ |- _ =>
    (move/(ccache_compatible_find_cbt_none _ Hcc): Hff => Hff);
    rewrite Hf in Hff; discriminate
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_het ?e ?fc = None,
    Hf : CompCache.find_het ?e ?c = Some _ |- _ =>
    (move/(ccache_compatible_find_het_none _ Hcc): Hff => Hff);
    rewrite Hf in Hff; discriminate
  | Hcc : ccache_compatible ?fc ?c,
    Hff : find_hbt ?e ?fc = None,
    Hf : CompCache.find_hbt ?e ?c = Some _ |- _ =>
    (move/(ccache_compatible_find_hbt_none _ Hcc): Hff => Hff);
    rewrite Hf in Hff; discriminate
  end.

Ltac myauto ::=
  repeat
    match goal with
    | |- _ /\ _ => split
    | |- ?e = ?e => reflexivity
    | H : ?p |- ?p => assumption
    | |- (_, _, _, _, _, _) = (_, _, _, _, _, _) -> _ =>
      case=> ? ? ? ? ? ?; subst
    | |- (_, _, _, _, _) = (_, _, _, _, _) -> _ =>
      case=> ? ? ? ? ?; subst
    | H1 : ?e = Some _, H2 : ?e = None |- _ =>
      rewrite H1 in H2; discriminate
    (* apply induction hypothesis *)
    | mk_env_exp_fccache_valid :
        (forall (iE : env) (s : SSAStore.t) (e : QFBV.exp)
                (im : vm) (ifc : ccache) (ic : CompCache.compcache)
                (ig : generator) (ofE oE : env) (ofm : vm)
                (ofc : ccache) (ofg : generator) (ofcs : seq cnf)
                (oflrs : word) (om : vm) (oc : CompCache.compcache)
                (og : generator) (ocs : cnf) (olrs : word),
            ccache_compatible ifc ic ->
            mk_env_exp_fccache iE s im ifc ig e =
            (ofE, ofm, ofc, ofg, ofcs, oflrs) ->
            mk_env_exp_ccache im ic s iE ig e = (om, oc, oE, og, ocs, olrs) ->
            ofE = oE /\
            ofm = om /\
            ccache_compatible ofc oc /\
            ofg = og /\
            cnf_eqsat (tflatten ofcs) ocs /\
            cnf_eqnew (tflatten ofcs) ocs /\ oflrs = olrs),
      Hcc : ccache_compatible ?ifc ?ic,
      Hv1 : mk_env_exp_fccache ?iE ?s ?im ?ifc ?ig ?e = _,
      Hv2 : mk_env_exp_ccache ?im ?ic ?s ?iE ?ig ?e = _ |- _ =>
      let H1 := fresh in
      let H2 := fresh in
      let H3 := fresh in
      let H4 := fresh in
      let H5 := fresh in
      let H6 := fresh in
      let H7 := fresh in
      (move: (mk_env_exp_fccache_valid _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
                                       Hcc Hv1 Hv2));
      (move=> [H1 [H2 [H3 [H4 [H5 [H6 H7]]]]]]);
      subst; clear Hv1 Hv2
    | mk_env_bexp_fccache_valid :
        (forall (iE : env) (s : SSAStore.t) (e : QFBV.bexp)
                (im : vm) (ifc : ccache) (ic : CompCache.compcache)
                (ig : generator) (ofE oE : env) (ofm : vm)
                (ofc : ccache) (ofg : generator) (ofcs : seq cnf)
                (oflr : literal) (om : vm) (oc : CompCache.compcache)
                (og : generator) (ocs : cnf) (olr : literal),
            ccache_compatible ifc ic ->
            mk_env_bexp_fccache iE s im ifc ig e =
            (ofE, ofm, ofc, ofg, ofcs, oflr) ->
            mk_env_bexp_ccache im ic s iE ig e = (om, oc, oE, og, ocs, olr) ->
            ofE = oE /\
            ofm = om /\
            ccache_compatible ofc oc /\
            ofg = og /\
            cnf_eqsat (tflatten ofcs) ocs /\
            cnf_eqnew (tflatten ofcs) ocs /\ oflr = olr),
      Hcc : ccache_compatible ?ifc ?ic,
      Hv1 : mk_env_bexp_fccache ?iE ?s ?im ?ifc ?ig ?e = _,
      Hv2 : mk_env_bexp_ccache ?im ?ic ?s ?iE ?ig ?e = _ |- _ =>
      let H1 := fresh in
      let H2 := fresh in
      let H3 := fresh in
      let H4 := fresh in
      let H5 := fresh in
      let H6 := fresh in
      let H7 := fresh in
      (move: (mk_env_bexp_fccache_valid _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
                                        Hcc Hv1 Hv2));
      (move=> [H1 [H2 [H3 [H4 [H5 [H6 H7]]]]]]);
      subst; clear Hv1 Hv2
    (**)
    | Hv1 : mk_env_var ?iE ?g ?bs ?v = _,
      Hv2 : mk_env_var ?iE ?g ?bs ?v = _ |- _ =>
      let H1 := fresh in
      let H2 := fresh in
      let H3 := fresh in
      let H4 := fresh in
      (rewrite Hv1 in Hv2); (case: Hv2 => ? ? ? ?; subst)
    | Hv1 : mk_env_eunop ?op ?iE ?g ?ls = _,
      Hv2 : mk_env_eunop ?op ?iE ?g ?ls = _ |- _ =>
      let H1 := fresh in
      let H2 := fresh in
      let H3 := fresh in
      let H4 := fresh in
      (rewrite Hv1 in Hv2); (case: Hv2 => ? ? ? ?; subst)
    | Hv1 : mk_env_ebinop ?op ?iE ?g ?ls1 ?ls2 = _,
      Hv2 : mk_env_ebinop ?op ?iE ?g ?ls1 ?ls2 = _ |- _ =>
      let H1 := fresh in
      let H2 := fresh in
      let H3 := fresh in
      let H4 := fresh in
      (rewrite Hv1 in Hv2); (case: Hv2 => ? ? ? ?; subst)
    | Hv1 : mk_env_bbinop ?op ?iE ?g ?ls1 ?ls2 = _,
      Hv2 : mk_env_bbinop ?op ?iE ?g ?ls1 ?ls2 = _ |- _ =>
      let H1 := fresh in
      let H2 := fresh in
      let H3 := fresh in
      let H4 := fresh in
      (rewrite Hv1 in Hv2); (case: Hv2 => ? ? ? ?; subst)
    | Hv1 : mk_env_ite ?iE ?g ?l ?ls1 ?ls2 = _,
      Hv2 : mk_env_ite ?iE ?g ?l ?ls1 ?ls2 = _ |- _ =>
      let H1 := fresh in
      let H2 := fresh in
      let H3 := fresh in
      let H4 := fresh in
      (rewrite Hv1 in Hv2); (case: Hv2 => ? ? ? ?; subst)
    (**)
    | |- _ => dcase_bb_ccache || dcase_mk_env_compcache || dcase_mk_env_ccache
              || simpl_ccache_compatible || simpl_ccache_compatible_find || solve_eqnew
    end.

Lemma mk_env_exp_fccache_valid
      iE s e im ifc ic ig ofE oE ofm ofc ofg ofcs oflrs om oc og ocs olrs :
  ccache_compatible ifc ic ->
  mk_env_exp_fccache iE s im ifc ig e = (ofE, ofm, ofc, ofg, ofcs, oflrs) ->
  mk_env_exp_ccache im ic s iE ig e = (om, oc, oE, og, ocs, olrs) ->
  ofE = oE
  /\ ofm = om
  /\ ccache_compatible ofc oc
  /\ ofg = og
  /\ cnf_eqsat (tflatten ofcs) ocs
  /\ cnf_eqnew (tflatten ofcs) ocs
  /\ oflrs = olrs
with
mk_env_bexp_fccache_valid
  iE s e im ifc ic ig ofE oE ofm ofc ofg ofcs oflr om oc og ocs olr :
  ccache_compatible ifc ic ->
  mk_env_bexp_fccache iE s im ifc ig e = (ofE, ofm, ofc, ofg, ofcs, oflr) ->
  mk_env_bexp_ccache im ic s iE ig e = (om, oc, oE, og, ocs, olr) ->
  ofE = oE
  /\ ofm = om
  /\ ccache_compatible ofc oc
  /\ ofg = og
  /\ cnf_eqsat (tflatten ofcs) ocs
  /\ cnf_eqnew (tflatten ofcs) ocs
  /\ oflr = olr.
Proof.
  (* mk_env_exp_fccache_valid *)
  move=> Hcc. case: e => /=.
  - move=> v. by myauto.
  - move=> bs. by myauto.
  - move=> op e. by myauto.
  - move=> op e1 e2. by myauto.
  - move=> e1 e2 e3. by myauto.
  (* mk_env_bexp_fccache_valid *)
  move=> Hcc. case: e => /=.
  - by myauto.
  - by myauto.
  - move=> op e1 e2. by myauto.
  - move=> e. by myauto.
  - move=> e1 e2. by myauto.
  - move=> e1 e2. by myauto.
Qed.


Require Import RelationClasses.
Require Import List.

Require Import sflib.
From Paco Require Import paco.

Require Import Basic.
Require Import Axioms.
Require Import Loc.
Require Import LibTactics.
Require Import Integers.
Require Import Language.
Require Import ZArith.
Require Import Maps.
Require Import FSets.
Require Import FSetInterface.
Require Import Lattice.
Require Import Event.
Require Import Syntax.
Require Import Semantics.

Require Import Kildall.
Require Import LiveAnalysis.
Require Import CorrectOpt.
Require Import DCE.

Require Import Language.
Require Import Time.
Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import MsgMapping.
Require Import DelaySet.

Require Import WFConfig.
Require Import CompAuxDef.
Require Import MemoryProps.
Require Import promiseCertifiedAux.
Require Import Mem_at_eq_lemmas.
Require Import PromiseInjectionWeak.

(** * Well-formed state lemmas *)
Lemma concrete_incr_closed_tm_prsv
      tm mem mem'
      (CONCRETE_INCR: forall loc to from val R,
          Memory.get loc to mem = Some (from, Message.concrete val R) ->
          exists from' R', Memory.get loc to mem' = Some (from', Message.concrete val R'))
      (CLOSED_VIEW: Memory.closed_timemap tm mem):
  Memory.closed_timemap tm mem'.
Proof.
  unfold Memory.closed_timemap in *.
  ii. specialize (CLOSED_VIEW loc). des.
  eapply CONCRETE_INCR in CLOSED_VIEW. des.
  do 3 eexists. eauto.
Qed.

Lemma concrete_incr_closed_view_prsv
      view mem mem'
      (CONCRETE_INCR: forall loc to from val R,
          Memory.get loc to mem = Some (from, Message.concrete val R) ->
          exists from' R', Memory.get loc to mem' = Some (from', Message.concrete val R'))
      (CLOSED_VIEW: Memory.closed_view view mem):
  Memory.closed_view view mem'.
Proof.
  inv CLOSED_VIEW.
  econs; eauto.
  eapply concrete_incr_closed_tm_prsv; eauto.
  eapply concrete_incr_closed_tm_prsv; eauto.
Qed.

Lemma concrete_incr_local_wf_prsv
      mem mem' lc
      (CONCRETE_INCR: forall loc to from val R,
          Memory.get loc to mem = Some (from, Message.concrete val R) ->
          exists from' R', Memory.get loc to mem' = Some (from', Message.concrete val R'))
      (PRM_LESS: Memory.le (Local.promises lc) mem')
      (LOCAL_WF: Local.wf lc mem):
  Local.wf lc mem'.
Proof.
  inv LOCAL_WF.
  econs; eauto.
  inv TVIEW_CLOSED.
  econs; eauto.
  ii.
  eapply concrete_incr_closed_view_prsv; eauto.
  eapply concrete_incr_closed_view_prsv; eauto.
  eapply concrete_incr_closed_view_prsv; eauto.
Qed.

(** * Step lemmas *)
Lemma Thread_na_step_to_na_step_dset
      lang lo (e1 e2: Thread.t lang) index
      (NA_STEP: Thread.na_step lo e1 e2):
  na_step_dset lo (e1, @dset_init index) (e2, @dset_init index).
Proof.
  inv NA_STEP.
  eapply na_steps_dset_read; eauto.
  ii. rewrite dset_gempty in H. ss.
  eapply na_steps_dset_write; eauto.
  econs; eauto.
Qed.

Lemma Thread_na_steps_to_na_steps_dset
      lang lo (e1 e2: Thread.t lang) index
      (NA_STEPS: rtc (Thread.na_step lo) e1 e2):
  rtc (na_step_dset lo) (e1, @dset_init index) (e2, @dset_init index).
Proof.
  induction NA_STEPS; ii; eauto.
  econs; eauto.
  eapply Thread_na_step_to_na_step_dset; eauto.
Qed.

Lemma injection_read
      inj lo
      tview_tgt prm_tgt mem_tgt loc to v R or tview_tgt' prm_tgt'
      tview_src prm_src mem_src
      (LOCAL_READ: Local.read_step (Local.mk tview_tgt prm_tgt) mem_tgt loc to v R or
                                   (Local.mk tview_tgt' prm_tgt') lo)
      (MSG_INJ: MsgInj inj mem_tgt mem_src)
      (INJ_PLN: inj loc (View.pln (TView.cur tview_tgt) loc) = Some (View.pln (TView.cur tview_src) loc))
      (INJ_RLX: inj loc (View.rlx (TView.cur tview_tgt) loc) = Some (View.rlx (TView.cur tview_src) loc))
      (MEM_CLOSED: Memory.closed mem_tgt):
  exists tview_src' to' R',
    <<LOCAL_READ_SRC: Local.read_step (Local.mk tview_src prm_src) mem_src loc to' v R' or
                                      (Local.mk tview_src' prm_src) lo>> /\
    <<INJ_PLN': inj loc (View.pln (TView.cur tview_tgt') loc) = Some (View.pln (TView.cur tview_src') loc)>> /\
    <<INJ_RLX': inj loc (View.rlx (TView.cur tview_tgt') loc) = Some (View.rlx (TView.cur tview_src') loc)>> /\
    <<INJ_TO: inj loc to = Some to'>> /\
    <<VIEW_INJ: opt_ViewInj inj R R'>> /\
    <<CLOSED_VIEW: Memory.closed_opt_view R mem_tgt>>.
Proof.
  inv LOCAL_READ. inv LC2. inv MSG_INJ.
  exploit SOUND; eauto. ii; des.
  do 3 eexists.
  split. econs; eauto. ss. inv READABLE. econs; eauto.
  eapply monotonic_inj_implies_le_prsv; eauto.
  ii.
  exploit RLX; eauto. ii.
  eapply monotonic_inj_implies_le_prsv; eauto.

  ss. splits; eauto.
  {
    destruct (Ordering.le Ordering.acqrel or) eqn:ORD_ACQREL.
    {
      unfold View.singleton_ur_if. unfold TimeMap.join; ss.
      destruct (Ordering.le Ordering.relaxed or) eqn:ORD_RELAX; ss.

      unfold TimeMap.singleton; ss. do 2 (rewrite Loc_add_eq).
      exploit wf_msginj_implies_closed_view; [ | eapply MEM_CLOSED | eapply GET | eauto..].
      econs; eauto. ii; des; subst.
      {
        ss. destruct R'; ss. unfold TimeMap.bot. do 2 (rewrite Time_join_bot).
        eapply inj_join_comp; eauto.
      }
      {
        destruct R'; ss.
        eapply inj_join_comp; eauto.
        eapply inj_join_comp; eauto.
        clear - x2 x0. inv x2. unfold closed_TMapInj in H.
        specialize (H loc). des. unfold ViewInj in x0. destruct view, t; ss. des.
        unfold TMapInj in x0.
        exploit x0; eauto. ii; subst. eauto.
      }

      unfold TimeMap.bot. do 2 (rewrite Time_join_bot).
      exploit wf_msginj_implies_closed_view; [ | eapply MEM_CLOSED | eapply GET | eauto..].
      econs; eauto. ii; des; subst.
      {
        destruct R'; ss. unfold TimeMap.bot; ss.
        do 2 (rewrite Time_join_bot). eauto.
      }
      {
        destruct R'; ss.
        eapply inj_join_comp; eauto.
        clear - x2 x0. inv x2. unfold closed_TMapInj in H.
        specialize (H loc). des. unfold ViewInj in x0. destruct view, t; ss. des.
        unfold TMapInj in x0.
        exploit x0; eauto. ii; subst. eauto.
      }
    }
    {
      unfold View.singleton_ur_if. unfold TimeMap.join; ss.
      destruct (Ordering.le Ordering.relaxed or) eqn:ORD_RELAX; ss.

      unfold TimeMap.singleton; ss. do 2 (rewrite Loc_add_eq).
      unfold TimeMap.bot; ss. do 2 (rewrite Time_join_bot).
      eapply inj_join_comp; eauto.

      unfold TimeMap.bot; ss. do 4 (rewrite Time_join_bot). eauto.
    }
  }
  {
    destruct (Ordering.le Ordering.acqrel or) eqn:ORD_ACQREL.
    {
      unfold View.singleton_ur_if. unfold TimeMap.join; ss.
      destruct (Ordering.le Ordering.relaxed or) eqn:ORD_RELAX; ss.

      unfold TimeMap.singleton; ss. do 2 (rewrite Loc_add_eq).
      exploit wf_msginj_implies_closed_view; [ | eapply MEM_CLOSED | eapply GET | eauto..].
      econs; eauto. ii; des; subst.
      {
        ss. destruct R'; ss. unfold TimeMap.bot. do 2 (rewrite Time_join_bot).
        eapply inj_join_comp; eauto.
      }
      {
        destruct R'; ss.
        eapply inj_join_comp; eauto.
        eapply inj_join_comp; eauto.
        clear - x2 x0. inv x2. unfold closed_TMapInj in H0.
        specialize (H0 loc). des. unfold ViewInj in x0. destruct view, t; ss. des.
        unfold TMapInj in x1.
        exploit x1; eauto. ii; subst. eauto.
      }

      unfold TimeMap.singleton; ss. do 2 (rewrite Loc_add_eq).
      exploit wf_msginj_implies_closed_view; [ | eapply MEM_CLOSED | eapply GET | eauto..].
      econs; eauto. ii; des; subst.
      {
        destruct R'; ss. unfold TimeMap.bot; ss.
        do 2 (rewrite Time_join_bot).
        eapply inj_join_comp; eauto.
      }
      {
        destruct R'; ss.
        eapply inj_join_comp; eauto.
        eapply inj_join_comp; eauto.
        clear - x2 x0. inv x2. unfold closed_TMapInj in H0.
        specialize (H0 loc). des. unfold ViewInj in x0. destruct view, t; ss. des.
        unfold TMapInj in x1.
        exploit x1; eauto. ii; subst. eauto.
      }
    }
    {
      unfold View.singleton_ur_if. unfold TimeMap.join; ss.
      destruct (Ordering.le Ordering.relaxed or) eqn:ORD_RELAX; ss.

      unfold TimeMap.singleton; ss. do 2 (rewrite Loc_add_eq).
      unfold TimeMap.bot; ss. do 2 (rewrite Time_join_bot).
      eapply inj_join_comp; eauto.

      unfold TimeMap.bot; ss. do 2 (rewrite Time_join_bot).
      unfold TimeMap.singleton; ss. do 2 (rewrite Loc_add_eq).
      eapply inj_join_comp; eauto.
    }
  }
  {
    clear - GET MEM_CLOSED.
    eapply closed_mem_implies_closed_msg; eauto.
  }
Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import Div2 Even.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
From mathcomp Require Import tuple.
Require Import ssrZ ZArith_ext String_ext ssrnat_ext seq_ext machine_int.
Import MachineInt.
Require Import C_types C_types_fp C_value C_expr C_expr_equiv C_expr_ground.
Require Import C_seplog C_tactics.
Require Import rfc5246.
Import RFC5932.
Require Import POLAR_library_functions POLAR_library_functions_triple.
Require Import POLAR_ssl_ctxt POLAR_parse_client_hello POLAR_parse_client_hello_header.
Require Import POLAR_parse_client_hello_triple3.

Close Scope select_scope.

Local Open Scope nat_scope.
Local Open Scope string_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope machine_int_scope.
Local Open Scope seq_ext_scope.
Local Open Scope C_assert_scope.
Local Open Scope C_expr_scope.
Local Open Scope C_cmd_scope.
Local Open Scope C_value_scope.
Local Open Scope C_types_scope.
Local Open Scope POLAR_scope.

(** * Verification of the ClientHello Parsing Program (2/4) *)

Section POLAR_parse_client_hello_triple.

Variable SI : seq (int 8).

Lemma POLAR_parse_client_hello_triple2 (BU RB ID : seq (int 8)) (CI : seq (int 32))
  (sz_BU : size BU = '| SSL_BUFFER_LEN |)
  (sz_ID : size ID = 32)
  (HCI : ciphers_seq CI)
  (cipher0 length0 : int 32)
  (bu rb id : (:* (ityp: uchar)).-phy)
  (ses : (:* (g.-typ: ssl_session)).-phy)
  (ciphers : (:* (ityp: sint)).-phy)
  (vssl : int ptr_len)
  (md5s sha1s : 5.-tuple (int ptr_len))  :
  let init_ssl_var := `! \b __ssl \= [ phy<=ptr _ vssl ]c in
  let init_id := [ id ]c |---> map phy_of_ui8 ID in
  let init_ses := ses |lV~> mk_ssl_session cipher0 length0 (ptr<=phy id) in
  let init_ciphers := [ ciphers ]c |--> map phy<=si32 CI in
  let final_bu := Final_bu SI bu in
  let final_ses := Final_ses SI CI ses id in
  let final_rb := Final_rb SI RB rb in
  let final_id := Final_id SI id in
  let final_ssl_context := Ssl_context (zext 24 S74.server_hello)
    (zext 24 (SI `_ maj_ver))
    (zext 24 (if (u2Z (SI `_ min_req) <=? u2Z (S621.TLSv11_min))%Z then
              SI `_ min_req else S621.TLSv11_min))
    (zext 24 (SI `_ maj_req)) (zext 24 (SI `_ min_req ))
    ses bu `( 0 )s_32 md5s sha1s ciphers rb in
  forall BU1, BU1 |{ 8, 5) = SI |{ 0, 5) -> size BU1 = size BU ->
  4 < size SI ->
  forall in_left, in_left = Z2u 32 5 ->
  let the_n := Z<=s ((zext 24 (BU1 `_ 11) `<< 8) `|` zext 24 (BU1 `_ 12)) in
  let the_n_plus5 := (5 + the_n)%Z in
  (45 <= the_n)%Z -> (the_n <= 512)%Z ->
  forall in_left2, in_left2 = Z2u 32 the_n_plus5 ->
  forall BU2 : seq (int 8),
  let Hbu := [ bu ]c |---> map phy_of_ui8 BU2 in
  BU2 |{ 8 + 5, Z.abs_nat the_n) = SI |{ 5, Z.abs_nat the_n) ->
  BU2 |{ 8, 5) = BU1 |{ 8, 5) ->
  size BU2 = size BU1 ->
  '| the_n_plus5 | <= size SI ->
  let Hbuf := `! \b __buf \= [ bu ]c \+ [ 13 ]sc in
  let Hn0 := `! \b __n0 \= [ in_left2 ]pc in
  let Hn_old := `! \b __n_old \= [ the_n ]sc in
  let Hn := `! \b __n \= __n0 \- [ 5 ]sc in
  BU1 `_ 8 `& Z2u 8 128  = Z2u 8 0 /\ BU1 `_ 8 = S621.handshake ->
  BU2 `_ 13 = S74.client_hello ->
  BU2 `_ 17 = S621.SSLv30_maj ->
  let Hbuf5 := `! \b __buf5 \= ([BU2 `_ 18]pc : exp sigma (ityp: uchar)) in
  let minver_exp := [BU2 `_ 18]pc \<= [ SSL_MINOR_VERSION_2 ]c \?
                    [BU2 `_ 18]pc \: [ SSL_MINOR_VERSION_2 ]c : exp sigma (g.-ityp: uchar) in
  let minver_u := si32<=phy (safe_cast_phy (ground_exp minver_exp Logic.eq_refl) sint Logic.eq_refl) in
  let reqmin_sslcontext := Ssl_context (zext 24 S74.client_hello)
      (si32<=phy (safe_cast_phy SSL_MAJOR_VERSION_3 sint Logic.eq_refl)) minver_u
      (zext 24 (BU2 `_ 17)) (zext 24 (BU2 `_ 18)) ses bu in_left2 md5s sha1s
      ciphers rb in
  let Hit := `! \b __it \= [ rb ]c in
  BU1 `_ 9 = S621.SSLv30_maj ->
  BU2 `_ 14 = zero8 ->
  let Hbuf2 := `! \b __buf2 \= [BU2 `_ 15]pc in
  let Hbuf3 := `! \b __buf3 \= [BU2 `_ 16]pc in
  {{ Hbuf3 ** Hbuf2 ** Hit ** Hbuf5 ** Hn ** Hn_old ** Hn0 ** Hbuf **
     Hbu ** reqmin_sslcontext ** success ** init_ssl_var ** final_rb **
     init_id ** init_ses ** init_ciphers }}
  ssl_parse_client_hello3 (ssl_parse_client_hello4 ssl_parse_client_hello5)
  {{ error \\//
     success ** final_bu ** final_ses ** final_rb **
     final_id ** final_ssl_context ** !!( PolarSSLClientHellop SI ) ** init_ciphers }}.
Proof.
move=> init_ssl_var init_id init_ses init_ciphers final_bu
  final_ses final_rb final_id final_ssl_context BU1 BU1SI sz_BU1 size_SI
  in_left in_left_5 the_n the_n_plus5 HN1 HN2 in_left2 Hin_left2 BU2
  Hbu BU2SI BU2BU1 sz_BU2 HSI_new Hbuf Hn0 Hn_old Hn BU1_8 BU2_13
  BU2_17 Hbuf5 minver_exp minver_u reqmin_sslcontext Hit BU1_9 BU2_14 Hbuf2
  Hbuf3.

unfold ssl_parse_client_hello3.

(** If \b __n \!= [ 4 ]sc \+ ((int) __buf2 \<< [ 8 ]sc \| (int) __buf3) Then *)
(**   _ret <- [ POLARSSL_ERR_SSL_BAD_HS_CLIENT_HELLO ]c; ret *)

idtac "36) ifte".

Hoare_ifte_bang Hm_old; first by apply POLAR_ret_err.

pose Hm := `! \b __n \= [4 ]sc \+
  ((int) ([ BU2 `_ 15 ]pc : exp sigma (ityp: uchar)) \<< [8 ]sc \|
  (int) ([ BU2 `_ 16 ]pc : exp sigma (ityp: uchar))).

Hoare_L_stren_by Hm (Hbuf2 :: Hbuf3 :: Hm_old :: nil).
  unfold Hm, Hbuf2, Hbuf3, Hm_old.
  Ent_LR_rewrite_eq_e 0 (* buf3 *).
  do 2 Ent_L_subst_apply; Ent_R_subst_apply.
  Ent_LR_rewrite_eq_e 0 (* buf2 *).
  Ent_R_subst_apply; Ent_L_subst_apply.
  rewrite bneg_neq_eq; by apply ent_id.

Hoare_L_contract_bbang Hbuf2.
Hoare_L_contract_bbang Hbuf3.
Hoare_L_contract_bbang Hm_old.
clear Hbuf2 Hbuf3 Hm_old.

(** _buf38 <-* __buf \+ [ 38 ]sc; *)

idtac "37) lookup".

(* 51 = 8 + 5 + 38 *)
pose Hbuf38 := `! \b __buf38 \= ([ BU2 `_ 51 ]pc : exp sigma (ityp: uchar)).
Hoare_seq_ext Hbuf38.
  Hoare_frame (Hbu :: Hbuf :: nil) (Hbu :: Hbuf :: Hbuf38 :: nil).
  apply hoare_lookup_mapstos_fit_stren with (i := 51) (l := map phy_of_ui8 BU2) (e := [ bu ]c).
  - by rewrite size_map sz_BU2 sz_BU1 sz_BU inj_mult Z_of_nat_Zabs_nat.
  - apply ent_R_lookup_mapstos_fit_trans.
    + by rewrite size_map sz_BU2 sz_BU1 sz_BU.
    + Ent_decompose (0 :: nil) (1 :: nil); first by apply ent_id.
      Ent_decompose (0 :: nil) (0 :: nil); last by [].
      unfold Hbuf.
      Ent_LR_rewrite_eq_p 0 (* buf *).
      Ent_R_subst_apply.
      Bbang2sbang.
      Ent_R_sbang 0; last by [].
      Rewrite_ground_bexp @CaddnpA => //=.
      Rewrite_ground_bexp @sequiv_add_e_sc => //=.
      by rewrite gb_eq_p.
    + rewrite [nth] lock.
      Ent_R_subst_con_distr.
      do 3 Ent_R_subst_apply.
      apply monotony_L.
      rewrite -lock (nth_map zero8); last by rewrite sz_BU2 sz_BU1 sz_BU.
      by Ent_monotony0.

(** _sess_len <- (int) __buf38; *)

idtac "38) assign".

pose Hsess_len := `! \b __sess_len \= (int) ([ BU2 `_ 51 ]pc : exp _ (ityp: uchar)).
Hoare_seq_ext Hsess_len.

  Hoare_L_dup (Hbuf38 :: nil).
  Hoare_frame (Hbuf38 :: nil) (Hsess_len :: nil).
  apply hoare_assign_stren.
  Ent_R_subst_apply.
  unfold Hbuf38.
  Ent_R_rewrite_eq_e 0 (* buf38 *).
  Ent_R_subst_apply.
  by Ent_monotony0.

Hoare_L_contract_bbang Hbuf38; clear Hbuf38.

(** If \b __sess_len \< [ 0 ]sc \|| __sess_len \> [ 32 ]sc
    \|| [ Z<=nat 45 ]sc \+ __sess_len \>= [ 5 ]sc \+ __n_old
    Then *)
(**   _ret <- [ POLARSSL_ERR_SSL_BAD_HS_CLIENT_HELLO ]c; Return *)

idtac "39) ifte".

apply hoare_ifte_bang; first by apply POLAR_ret_err.

rewrite -bbang_bneg_or.
set Hsess_len_2 := `! \~b \b __sess_len \< [0 ]sc \|| __sess_len \> [ 32 ]sc.
set Hsess_len_3 := `! \~b \b [ Z<=nat csuites.+1 ]sc \+ __sess_len \>= [ 5 ]sc \+ __n_old.

(** _ssl_session_0 <-* __ssl &-> _session; *)

idtac "40) lookup".

pose Hssl_session_0 := `! \b __ssl_session_0 \= [ ses ]c.

Hoare_seq_ext Hssl_session_0.
  Hoare_frame (reqmin_sslcontext :: nil) (reqmin_sslcontext :: Hssl_session_0 :: nil).
  apply hoare_lookup_fldp_stren, ent_R_lookup_fldp with (pv := ses).
  - by rewrite get_session_ssl_ctxt /phylog_conv /= ptr_of_phyK.
  - Ent_R_subst_con_distr. (* 1 *)
    rewrite /reqmin_sslcontext /Ssl_context.
    do 2 Ent_R_subst_apply.
    by Ent_monotony0.

pose Hsess_len3'' := !!(Z<=nat csuites.+1 + Z<=u BU2 `_ 51 < the_n_plus5)%Z.
Hoare_L_stren_by Hsess_len3'' (Hsess_len :: Hn_old :: Hsess_len_3 :: nil).
  unfold Hsess_len, Hsess_len_3, Hn_old.
  Ent_LR_rewrite_eq_e 0 (* sess_len *).
  do 2 Ent_L_subst_apply; Ent_R_subst_apply.
  fold Hsess_len3''.
  Ent_LR_rewrite_eq_e 0 (* n_old *).
  Ent_R_subst_apply; Ent_L_subst_apply.
  Bbang2sbang.
  apply ent_sbang_sbang.
  rewrite gb_bneg_bop_r_ge.
  move/Zlt_gb. move/(_ erefl erefl).
  rewrite si32_of_phy_gb_add_e i32_ge_s_cst_e ge_cast_sint_cst_8c phy_of_si32K.
  rewrite si32_of_phy_gb_add_e 2!i32_ge_s_cst_e.
  have H1 : (0 <= Z<=nat csuites.+1 + Z<=u BU2 `_ 51 < 2 ^^ 31)%Z.
    split.
      apply (@leZ_trans (45%Z + Z0)%Z) => //; exact/leZ_add2l/min_u2Z.
    apply (@ltZ_trans (45%Z + 2 ^^ 8)%Z) => //; exact/ltZ_add2l/max_u2Z.
  rewrite s2Z_add; last first.
    rewrite Z2sK; last by [].
    rewrite (s2Z_zext 24) //.
    split; last by case: H1.
    apply (@leZ_trans Z0) => //; by case: H1.
  rewrite Z2sK // s2Z_add; last first.
    rewrite Z2sK //.
    clear -HN1 HN2.
    rewrite Z2sK; last by simpl expZ; lia.
    simpl expZ; lia.
  rewrite Z2sK // Z2sK; last by simpl expZ; lia.
  rewrite (s2Z_zext 24) //.
  apply.
  exact H1.
  simpl expZ; lia.

Hoare_L_contract_bbang Hsess_len_3; clear Hsess_len_3.
apply hoare_pullout_sbang => Hsess_len_3'.
clear Hsess_len3''.

(** __ssl_session_0 &-> _length *<- __sess_len; *)

idtac "41) mutation".

pose Hses_length := ses |lV~> mk_ssl_session cipher0 (zext 24 (BU2 `_ 51)) (ptr<=phy id) : assert.

Hoare_seq_replace1 init_ses Hses_length.
  Hoare_L_dup (Hsess_len :: Hssl_session_0 :: nil).
  Hoare_frame (init_ses :: Hsess_len :: Hssl_session_0 :: nil) (Hses_length :: nil).
  unfold init_ses, Hses_length, mk_ssl_session.
  set ses_hdr_pre := mk_ssl_sess_logs _ _ _.
  set ses_hdr_post := mk_ssl_sess_logs _ _ _.
  apply hoare_mutation_fldp_subst_ptr with (str := _ssl_session_0) (Hstr := Logic.eq_refl) (e'' := [ ses ]c).
  - Ent_decompose (0 :: 1 :: nil) (1 :: nil); by [| apply ent_id].
  - rewrite /=.
    apply hoare_mutation_fldp_subst_ityp with (str := _sess_len) (Hstr := Logic.eq_refl) (e := (int) ([ BU2`_51 ]pc : exp sigma (ityp: uchar))).
    + Ent_decompose (0 :: 2 :: nil) (1 :: nil); by [| apply ent_id].
    + rewrite /=.
      Hoare_L_contract_bbang Hsess_len; Hoare_L_contract_bbang Hssl_session_0.
      set tmp := safe_cast _ _ _ _ _.
      eapply hoare_weak; last first.
        have He2 : @vars _ sigma _ tmp = nil by [].
        apply hoare_mutation_fldp_local_forward_ground_lV with (val := mkSintLog (zext 24 (BU2`_51))) (He2 := He2).
        by rewrite /phylog_conv /= /tmp ge_cast_sint_cst_8c.
      rewrite /= -!Eqdep.Eq_rect_eq.eq_rect_eq /ses_hdr_post /mk_ssl_sess_logs /tmp; by apply ent_id.

(** _it <-* __ssl_session_0 &-> _id; *)

idtac "42) lookup".

Hoare_L_contract_bbang Hit; clear Hit.

pose Hit := `! \b __it \= [ id ]c.
Hoare_seq_ext Hit.
  Hoare_L_dup (Hssl_session_0 :: nil).
  Hoare_frame (Hses_length :: Hssl_session_0 :: nil) (Hses_length :: Hit :: nil).
  apply (hoare_lookup_fldp_subst _ _ssl_session_0 erefl ([ ses ]c)).
  - Ent_decompose (0 :: nil) (1 :: nil); by [apply ent_R_T | apply ent_id].
  - rewrite /=.
    Hoare_L_contract_bbang Hssl_session_0.
    apply hoare_lookup_fldp_stren.
    unfold Hses_length, mk_ssl_session.
    set ses_hdr := mk_ssl_sess_logs _ _ _.
    apply ent_R_lookup_fldp_trans with (pv := id) (lvs := ses_hdr).
    + by apply ent_R_con_T.
    + by rewrite /= -Eqdep.Eq_rect_eq.eq_rect_eq /phylog_conv /= ptr_of_phyK.
    + Ent_R_subst_con_distr.
      do 2 Ent_R_subst_apply.
      by Ent_monotony0.

(** _it <-memset( __it, [ 0 ]sc, [ 32 ]uc);; *)

idtac "43) memset".

pose init_id0 := [id ]c |---> nseq 32 pv0.
Hoare_seq_replace1 init_id init_id0.
  Hoare_frame (Hit :: init_id :: nil) (Hit :: init_id0 :: nil).
    by rewrite memset_input_inde.
  unfold init_id, init_id0.
  apply hoare_stren with (Hit ** __it |---> map phy_of_ui8 ID).
    unfold Hit at 1.
    Ent_R_rewrite_eq_p 0 (* it *).
    Ent_R_subst_con_distr.
    do 2 Ent_R_subst_apply.
    by Ent_monotony0.
  apply hoare_weak with (Hit ** __it |---> nseq 32 pv0).
    unfold Hit at 1.
    rewrite [nseq]lock.
    Ent_LR_rewrite_eq_p 0 (* it *).
    rewrite -lock.
    Ent_L_subst_apply.
    Ent_R_subst_con_distr.
    do 2 Ent_R_subst_apply.
    by Ent_monotony0.
  rewrite (_ : 32%Z = Z.of_nat 32) // (_ : [ 0 ]s = (phyint) (@pv0 _ (g.-ityp:uchar))); last first.
    apply mkPhy_irrelevance => /=.
    by rewrite zext_Z2u // Z2s_Z2u_k.

  Hoare_frame_remove (Hit :: nil); first by rewrite memset_input_inde.
  (* TODO: Hoare_frame_move seems to do a useless simpl *)
  apply memset_triple_cst_e.
  by rewrite size_map.

(** _ssl_session_0_length <-* __ssl_session_0 &-> _length; *)

idtac "44) lookup".

pose Hssl_session_0_length := `! \b __ssl_session_0_length \= (int) ([ BU2 `_ 51 ]pc : exp _ (ityp: uchar)).
Hoare_seq_ext Hssl_session_0_length.
  Hoare_L_dup (Hssl_session_0 :: nil).
  Hoare_frame (Hses_length :: Hssl_session_0 :: nil) (Hses_length :: Hssl_session_0_length :: nil).
  apply (hoare_lookup_fldp_subst _ _ssl_session_0 erefl ([ ses ]c)).
  - Ent_decompose (0 :: nil) (1 :: nil); by [apply ent_R_T | apply ent_id].
  - rewrite /=.
    Hoare_L_contract_bbang Hssl_session_0.
    apply hoare_lookup_fldp_stren.
    unfold Hses_length, mk_ssl_session.
    set ses_hdr := mk_ssl_sess_logs _ _ _.
    apply ent_R_lookup_fldp_trans with (pv := [zext 24 (BU2 `_ 51)]p) (lvs := ses_hdr).
    + by apply ent_R_con_T.
    + by rewrite /= -Eqdep.Eq_rect_eq.eq_rect_eq /phylog_conv /=.
    + Ent_R_subst_con_distr.
      do 2 Ent_R_subst_apply.
      rewrite -/Hses_length.
      Ent_monotony.
      Bbang2sbang.
      Ent_R_sbang 0; last by [].
      Rewrite_ground_bexp @sequiv_intsa_uchar_sc.
      Rewrite_ground_bexp @phy_of_si32_zext.
      Rewrite_ground_bexp @beq_exx.
      rewrite -(ground_bexp_sem (store0 sigma)).
      by apply: one_uc.

(** _it <-* __ssl_session_0 &-> _id; *)

idtac "45) lookup".

Hoare_L_contract_bbang Hit; clear Hit.

pose Hit := `! \b __it \= [ id ]c.
Hoare_seq_ext Hit.
  Hoare_L_dup (Hssl_session_0 :: nil).
  Hoare_frame (Hses_length :: Hssl_session_0 :: nil) (Hses_length :: Hit :: nil).
  apply (hoare_lookup_fldp_subst _ _ssl_session_0 Logic.eq_refl ([ ses ]c)).
  - Ent_decompose (0 :: nil) (1 :: nil); by [ | apply ent_id].
  - rewrite /=.
    Hoare_L_contract_bbang Hssl_session_0.
    apply hoare_lookup_fldp_stren.
    unfold Hses_length, mk_ssl_session.
    set ses_hdr := mk_ssl_sess_logs _ _ _.
    apply ent_R_lookup_fldp_trans with (pv := id) (lvs := ses_hdr).
    - by apply ent_R_con_T.
    - by rewrite /= -Eqdep.Eq_rect_eq.eq_rect_eq /phylog_conv /= ptr_of_phyK.
    - Ent_R_subst_con_distr.
      do 2 Ent_R_subst_apply.
      rewrite -/Hses_length.
      by Ent_monotony0.

(** memcpy _it Logic.eq_refl __it (__buf \+ [ 39 ]sc) (UINT) __ssl_session_0_length; *)

idtac "46) memcpy".

Hoare_stren_pull_out (Hsess_len ** Hsess_len_2) (u2Z (BU2 `_ 51) <= 32)%Z.
  unfold Hsess_len, Hsess_len_2.
  Ent_LR_rewrite_eq_e 0 (* sess_len *).
  do 2 Ent_LR_subst_apply.
  rewrite <- bbang_bneg_or.
  rewrite -CleqNgt.
  Ent_L_contract_bbang 0.
  Bbang2sbang.
  Ent_L_sbang 0 => H1.
  Ent_R_sbang 0; last by [].
  rewrite -(ground_bexp_sem (@store0 _ sigma)) in H1.
  apply bop_re_le_Zle in H1.
  rewrite 2!(ground_exp_sem (@store0 _ sigma)) in H1.
  by rewrite s2Z_ge_s_cst_e // s2Z_si32_of_phy_safe_cast eval_pv phy_of_ui8K in H1.
move=> BU_51.

have BU1_51 : u2nat (BU2 `_ 51) <= 32.
  rewrite [X in _ <= X](_ : 32 = '| 32 |) //; apply/leP; apply Zabs_nat_le.
  by split => //; first by apply min_u2Z.

Hoare_seq_replace1 init_id0 final_id.

  unfold Hbu.
  rewrite -(cat_take_drop 52%nat BU2) map_cat.
  Rewrite_Precond @mapstos_fit_cat.
    reflexivity.
    by rewrite -map_cat cat_take_drop size_map sz_BU2 sz_BU1 inj_mult sz_BU sizeof_ityp Z_of_nat_Zabs_nat.
  Rewrite_Postcond @mapstos_fit_con.
    reflexivity.
    by rewrite -map_cat cat_take_drop size_map sz_BU2 sz_BU1 inj_mult sz_BU sizeof_ityp Z_of_nat_Zabs_nat.
  set Hbu1 := [ bu ]c |---> _.
  rewrite size_map size_take sz_BU2 sz_BU1 sz_BU /= -(cat_take_drop (u2nat (BU2 `_ 51)) (drop 52 BU2)) map_cat.
  Rewrite_Precond @mapstos_fit_cat.
    reflexivity.
    rewrite -map_cat cat_take_drop size_map size_drop sz_BU2 sz_BU1 sz_BU sizeof_ityp; by vm_compute.  rewrite size_map size_take size_drop sz_BU2 sz_BU1 sz_BU.
  have Htmp : u2nat (BU2 `_ 51) < Z.abs_nat SSL_BUFFER_LEN - 52 by apply leq_ltn_trans with 32.
  rewrite Htmp.
  Rewrite_Postcond @mapstos_fit_con.
    reflexivity.
    rewrite -map_cat cat_take_drop size_map size_drop sz_BU2 sz_BU1 sz_BU sizeof_ityp; by vm_compute.
  rewrite size_map size_take size_drop sz_BU2 sz_BU1 sz_BU Htmp.
  set Hbu2 := [ bu ]c \+ _ |---> _.
  set Hbu3 := [ bu ]c \+ _ \+ _ |---> _.
  rewrite /init_id0 -(cat_take_drop (u2nat (BU2 `_ 51)) (nseq 32 pv0)).
  Rewrite_Precond @mapstos_fit_cat.
    reflexivity.
    rewrite cat_take_drop size_nseq sizeof_ityp; by vm_compute.
  rewrite size_take (_ : (if _ then _ else _) = u2nat (BU2 `_ 51)); last first.
     case: ifP => //.
     move/negbT.
     rewrite -leqNgt => H.
     apply/eqP.
     by rewrite eqn_leq H /= [in X in _ <= X](_ : 32 = Z.abs_nat 32).
  have sess_len_SI : sess_len SI = nat<=u (BU2 `_ 51).
    rewrite /sess_len (_ : sid = 43) // (_ : SI `_ 43 = BU2 `_ 51) // /nth' (nth_slices _ _ _ (esym BU2SI)) //=.
    - apply (@leq_trans (5 + Z.abs_nat 45)) => //.
      rewrite leq_add2l.
      apply/leP.
      by apply Zabs_nat_le.
    - rewrite leqnn andbC /=.
      apply (@leq_trans (Z.abs_nat 45)) => //.
      by apply/leP/Zabs_nat_le.
  have -> : drop (u2nat (BU2 `_ 51)) (nseq 32 pv0) = nseq (32 - sess_len SI) pv0.
    move=> ? ?; by rewrite drop_nseq // sess_len_SI.
  set init_id1 := [ id ]c |---> _.
  rewrite {1}/u2nat Z_of_nat_Zabs_nat; last by apply min_u2Z.
  set init_id2 := [ id ]c \+ [ u2Z _ ]sc |---> _.
  rewrite /final_rb /Final_rb /final_id /Final_id /sess_len_SI.
  have SI_BU : SI |{ sid.+1, u2nat (BU2 `_ 51) ) = take (u2nat (BU2 `_ 51)) (drop 52 BU2).
    rewrite (_: take (u2nat (BU2 `_ 51)) (drop 52 BU2) = BU2 |{ 52, (u2nat (BU2 `_ 51)))); last by [].
    rewrite (_: sid.+1 = 44); last by [].
    rewrite {1}(_: 44 = 5 + 39) // {1}(_: 52 = (8 + 5) + 39) //.
    eapply slice_shift.
    - symmetry; by apply BU2SI.
    - apply/ltP; apply Nat2Z.inj_lt.
      rewrite inj_plus Z_of_nat_Zabs_nat; last by lia.
      rewrite /u2nat Z_of_nat_Zabs_nat; last by apply min_u2Z.
      rewrite (_ : Z<=nat csuites.+1 = 45%Z) // /the_n_plus5 in Hsess_len_3'.
      rewrite (_ : Z<=nat 39 = 39%Z) //; lia.
  have size_slice_51 : size (SI |{ sid.+1, u2nat (BU2 `_ 51))) = u2nat (BU2 `_ 51).
    rewrite SI_BU size_take size_drop (_ : u2nat (BU2 `_ 51) < size BU2 - 52) //.
    apply leq_trans with (Z.abs_nat SSL_BUFFER_LEN - 52) => //; by rewrite sz_BU2 sz_BU1 sz_BU.
  Rewrite_Postcond @mapstos_fit_con.
    reflexivity.
    by rewrite size_cat 1!size_map size_nseq sizeof_ityp sess_len_SI size_slice_51 subnKC.
  rewrite size_map sess_len_SI size_slice_51 SI_BU Z_of_nat_Zabs_nat; last by apply min_u2Z.
  set final_id1 := [ id ]c |---> _.
  rewrite -sess_len_SI.
  set final_id2 := [ id ]c \+ [ u2Z (BU2 `_ 51) ]sc |---> _.
  Hoare_frame (Hssl_session_0_length::Hbuf :: Hit :: Hbu2 :: init_id1 :: nil)
             (Hssl_session_0_length::Hbuf :: Hit :: Hbu2 :: final_id1 :: nil).
    by rewrite memcpy_input_inde.
  rewrite /Hit /Hbuf /Hbu2 /init_id1 /final_id1.
  apply hoare_stren with (`! \b __buf \= [ bu ]c \+ [ 13 ]sc **
   `! \b __it \= [ id ]c **
   Hssl_session_0_length **
   `! \b (UINT) __ssl_session_0_length \= [ zext 24 (BU2 `_ 51) ]pc **
   __buf \+ [ 39 ]sc |---> map phy_of_ui8 (take (u2nat (BU2 `_ 51)) (drop 52 BU2)) **
   __it |---> take (u2nat (BU2 `_ 51)) (nseq 32 pv0)).
    clear.
    unfold Hssl_session_0_length.
    set tmp := nseq 32 pv0.
    rewrite [tmp]lock.
    (* TODO: nseq gets simplified, need to remove simpl from Ent_R_rewrite_bbang_re *)
    Ent_R_rewrite_eq_e 0 (*ssl_session_0_length*).
    Ent_R_subst_con_distr.
    do 6 Ent_LR_subst_apply.
    Ent_R_rewrite_eq_p 0 (* buf *).
    Ent_R_subst_con_distr.
    do 6 Ent_LR_subst_apply.
    Ent_R_rewrite_eq_p 0 (* it *).
    Ent_R_subst_con_distr.
    do 6 Ent_LR_subst_apply.
    rewrite unsa_sa_i8_to_uchar_uint_to_phy.
    do 2 rewrite -> beq_pxx.
    do 2 rewrite -> beq_exx.
    rewrite /= CaddnpA; last 3 first.
      by rewrite sizeof_ityp.
      by rewrite sizeof_ityp.
      by rewrite sizeof_ityp.
    rewrite sequiv_add_e_sc //.
    Ent_decompose (0 :: nil) (4 :: nil); first by apply ent_id.
    rewrite bbang1 !coneP; by apply ent_id.

  apply hoare_weak with (`! \b __buf \= [ bu ]c \+ [ 13 ]sc **
    `! \b __it \= [ id ]c ** Hssl_session_0_length **
    `! \b (UINT) __ssl_session_0_length \= [ zext 24 (BU2 `_ 51) ]pc **
    __buf \+ [ 39 ]sc |---> map phy_of_ui8 (take (u2nat (BU2 `_ 51)) (drop 52 BU2)) **
    __it |---> map phy_of_ui8 (take (u2nat (BU2 `_ 51)) (drop 52 BU2))).
    clear.
    unfold Hssl_session_0_length at 1.
    Ent_LR_rewrite_eq_p 0 (* buf *).
    Ent_R_subst_con_distr.
    do 5 Ent_L_subst_apply.
    do 5 Ent_R_subst_apply.
    Ent_LR_rewrite_eq_p 0 (* it *).
    Ent_R_subst_con_distr.
    do 9 Ent_LR_subst_apply.
    Ent_decompose (3 :: nil) (4 :: nil); first by apply ent_id.
    rewrite CaddnpA; last 3 first.
      by rewrite sizeof_ityp.
      by rewrite sizeof_ityp.
      by rewrite sizeof_ityp.
    rewrite sequiv_add_e_sc //.
    Ent_decompose (0 :: nil) (0 :: nil); first by apply ent_id.
    Ent_L_contract_bbang 0.
    do 2 rewrite -> beq_pxx.
    rewrite bbang1.
    by Ent_monotony.
  set tmp := nseq 32 pv0.
  rewrite [tmp]lock.
  Hoare_frame_idx_tmp (3 :: 4 :: 5 :: nil) (3 :: 4 :: 5 :: nil); first by rewrite memcpy_input_inde.
  apply memcpy_triple => //.
  - rewrite size_map size_take (_ : _ < _); last by rewrite size_drop sz_BU2 sz_BU1 sz_BU.
    rewrite Z_of_nat_Zabs_nat; last exact: min_u2Z.
    by rewrite (u2Z_zext 24).
  - rewrite size_take -lock /= /u2nat (u2Z_zext 24).
    case: ifP => //.
    rewrite Z_of_nat_Zabs_nat //; last exact: min_u2Z.
    move/negbT.
    rewrite -leqNgt => H.
    suff K : '| (Z<=u BU2 `_ 51) | = 32.
      rewrite -[in X in X = _]K Z_of_nat_Zabs_nat //; exact: min_u2Z.
    apply/eqP.
    by rewrite eqn_leq H BU1_51.

(** _buf39_plus_sess_len <-* __buf \+ ([ 39 ]sc \+ __sess_len); *)

idtac "47) lookup".

(* ciphen len part 1 *)

pose Shigh := [ BU2 `_ (52 + nat<=u (BU2 `_ 51)) ]pc : exp sigma (g.-ityp: uchar).

pose Hbuf39_plus_sess_len := `! \b __buf39_plus_sess_len \= Shigh.
Hoare_seq_ext Hbuf39_plus_sess_len.
  Hoare_frame (Hbu :: Hbuf :: Hsess_len :: nil)
             (Hbu :: Hbuf :: Hsess_len :: Hbuf39_plus_sess_len :: nil).
  apply hoare_lookup_mapstos_fit_stren with (i := 52 + nat<=u (BU2 `_ 51)) (l := map phy_of_ui8 BU2) (e := [ bu ]c).
  - by rewrite size_map sizeof_ityp sz_BU2 sz_BU1 inj_mult sz_BU.
  - apply ent_R_lookup_mapstos_fit_trans.
    + rewrite size_map sz_BU2 sz_BU1 sz_BU //.
      apply leq_ltn_trans with (52 + 32); last by [].
      by rewrite leq_add2l BU1_51.
    + clear -BU_51.
      unfold Hbu.
      Ent_decompose (0 :: nil) (1 :: nil); first exact: ent_id.
      unfold Hbuf, Hsess_len.
      Ent_R_rewrite_eq_p 0 (* buf *).
      Ent_R_subst_con_distr.
      do 2 Ent_LR_subst_apply.
      Ent_LR_rewrite_eq_e 0 (* sess_len *).
      Ent_R_subst_con_distr.
      do 2 Ent_LR_subst_apply.
      rewrite sequiv_intsa_uchar_sc sequiv_add_e_sc_pos //; last 2 first.
        exact: min_u2Z.
        apply (@leZ_ltZ_trans (39 + 32)%Z) => //; lia.
      rewrite CaddnpA; last 3 first.
        by rewrite sizeof_ityp.
        rewrite sizeof_ityp mul1Z.
        move: (min_u2Z (BU2 `_ 51)) => ?; simpl expZ; lia.
        rewrite sizeof_ityp !mul1Z addZA.
        move: (min_u2Z (BU2 `_ 51)) => ?; simpl expZ; lia.
      rewrite sequiv_add_e_sc_pos //; last 2 first.
        move: (min_u2Z (BU2 `_ 51)) => ?; lia.
        apply (@leZ_ltZ_trans (13 + (39 + 32))) => //; lia.
      rewrite (_ : 13 + _ = Z.of_nat (52 + '| (u2Z (BU2 `_ 51)) |))%Z; last first.
         rewrite inj_plus Zabs2Nat.id_abs Z.abs_eq; [ring | exact: min_u2Z].
      rewrite beq_pxx bbang1; exact: ent_R_con_T.
    + rewrite addnC.
      Ent_R_subst_con_distr.
      unfold Hbu, Hbuf, Hsess_len, Hbuf39_plus_sess_len.
      do 4 Ent_LR_subst_apply.
      do 2 apply monotony_L.
      Ent_decompose (0 :: nil) (0 :: nil); first exact: ent_id.
      rewrite (nth_map zero8); last first.
        rewrite sz_BU2 sz_BU1 sz_BU.
        apply leq_ltn_trans with (Z.abs_nat 32 + 52) => //.
        rewrite leq_add2r.
        apply/leP/Zabs2Nat.inj_le => //; exact: min_u2Z.
      by rewrite addnC beq_exx bbang1.

(** _buf40_plus_sess_len <-* __buf \+ ([ 40 ]sc \+ __sess_len); *)

idtac "48) lookup".

pose Slow : @exp g sigma (g.-typ: ityp uchar) := [ BU2 `_ (53 + nat<=u (BU2 `_ 51)) ]pc.

pose Hbuf40_plus_sess_len := `! \b __buf40_plus_sess_len \= Slow.
Hoare_seq_ext Hbuf40_plus_sess_len.
  Hoare_frame (Hbu :: Hbuf :: Hsess_len :: nil)
             (Hbu :: Hbuf :: Hsess_len :: Hbuf40_plus_sess_len :: nil).
  apply hoare_lookup_mapstos_fit_stren with (i := 53 + Z.abs_nat (u2Z (BU2 `_ 51))) (l := map phy_of_ui8 BU2) (e := [ bu ]c).
  - rewrite size_map sizeof_ityp sz_BU2 sz_BU1 inj_mult sz_BU; by vm_compute.
  - apply ent_R_lookup_mapstos_fit_trans.
    + rewrite size_map sz_BU2 sz_BU1 sz_BU //.
      apply leq_ltn_trans with (53 + 32); last by [].
      by rewrite leq_add2l.
    + unfold Hbu.
      Ent_decompose (0 :: nil) (1 :: nil); first by apply ent_id.
      unfold Hbuf, Hsess_len, Hsess_len_2.
      Ent_R_rewrite_eq_p 0 (* buf *).
      Ent_R_subst_con_distr.
      do 2 Ent_LR_subst_apply.
      Ent_LR_rewrite_eq_e 0 (* sess_len *).
      Ent_R_subst_con_distr.
      do 2 Ent_LR_subst_apply.
      rewrite sequiv_intsa_uchar_sc sequiv_add_e_sc_pos //; last 2 first.
        by apply min_u2Z.
        apply (@leZ_ltZ_trans (40 + 32)%Z) => //; lia.
      rewrite CaddnpA; last 3 first.
        by rewrite sizeof_ityp.
        clear -BU_51.
        rewrite sizeof_ityp mul1Z.
        move: (min_u2Z (BU2`_51)) => ?; simpl expZ; lia.
        rewrite sizeof_ityp !mul1Z addZA.
        move: (min_u2Z (BU2`_51)) => ?; simpl expZ; lia.
      rewrite sequiv_add_e_sc_pos //; last 2 first.
        clear -BU_51.
        move: (min_u2Z (BU2 `_ 51)) => ?; lia.
        clear -BU_51.
        apply (@leZ_ltZ_trans (13 + (40 + 32))) => //; lia.
      rewrite (_ : 13 + _ = Z.of_nat (53 + Z.abs_nat (u2Z (BU2 `_ 51))))%Z; last first.
         rewrite inj_plus Zabs2Nat.id_abs Z.abs_eq; [ring | exact: min_u2Z].
      rewrite beq_pxx bbang1; exact: ent_R_con_T.
    + rewrite addnC.
      Ent_R_subst_con_distr.
      unfold Hbu, Hbuf, Hsess_len, Hbuf39_plus_sess_len.
      do 4 Ent_LR_subst_apply.
      Ent_decompose (0 :: 1 :: 2 :: nil) (0 :: 1 :: 2 :: nil); first by apply ent_id.
      rewrite (nth_map zero8); last first.
        rewrite sz_BU2 sz_BU1 sz_BU.
        apply leq_ltn_trans with (Z.abs_nat 32 + 53) => //.
        rewrite leq_add2r.
        apply/leP/Zabs2Nat.inj_le => //; exact: min_u2Z.
      by rewrite addnC beq_exx bbang1.

(** _ciph_len <- (int) __buf39_plus_sess_len \<\< [ 8 ]sc \| (int) __buf40_plus_sess_len; *)

idtac "49) assign".

pose Hciph_len := `! \b __ciph_len \= ((int) Shigh \<< [ 8 ]sc \| (int) Slow).
Hoare_seq_ext Hciph_len.
  Hoare_L_dup (Hbuf39_plus_sess_len :: Hbuf40_plus_sess_len :: nil).
  unfold final_id, Final_id, final_rb, Final_rb.
  Hoare_frame (Hbuf39_plus_sess_len :: Hbuf40_plus_sess_len :: nil) (Hciph_len :: nil).
  apply hoare_assign_stren.
  Ent_LR_subst_apply.
  unfold Hbuf39_plus_sess_len.
  Ent_LR_rewrite_eq_e 0. (* buf39+sess_len *)
  do 2 Ent_LR_subst_apply.
  Ent_LR_rewrite_eq_e 0. (* buf40+sess_len*)
  Ent_LR_subst_apply.
  by Ent_monotony0.

Hoare_L_contract_bbang Hbuf39_plus_sess_len.
Hoare_L_contract_bbang Hbuf40_plus_sess_len.
clear Hbuf39_plus_sess_len Hbuf40_plus_sess_len.

(**  If  \b __ciph_len \< [ 2 ]sc \|| __ciph_len \> [ 256 ]sc \||
          __ciph_len \% 1 \!= [ 0 ]sc \||
          [ Z<=nat 46 ]sc \+ __sess_len \+ __ciph_len \>= [ 5 ]sc \+ __n_old  Then *)
(**   _ret <- [ POLARSSL_ERR_SSL_BAD_HS_CLIENT_HELLO ]c; Return *)

idtac "50) ifte".

apply hoare_ifte_bang; first by apply POLAR_ret_err.
rewrite -bbang_bneg_or.
set Hciph_len_bound := `! \~b \b __ciph_len \< [ 2 ]sc \|| __ciph_len \> [ 256 ]sc \|| __ciph_len \% 1 \!= [ 0 ]sc.
set Hciph_len_bound2 := `! \~b \b [Z<=nat compmeth ]sc \+ __sess_len \+ __ciph_len \>= [ 5 ]sc \+ __n_old.
pose ciph_len_exp : exp sigma _ := (int) Shigh \<< [ 8 ]sc \| (int) Slow.
pose ciph_len_value := @ground_exp g sigma _ ciph_len_exp erefl.
pose ciph_len_value_Z := s2Z (si32<=phy ciph_len_value).
pose ciph_len_value_nat := '| ciph_len_value_Z |.
Hoare_stren_pull_out (Hciph_len ** Hciph_len_bound) (2 <= ciph_len_value_Z <= 256)%Z.
  rewrite /Hciph_len /Hciph_len_bound. rewrite -/ciph_len_exp.
  rewrite <- bbang_bneg_or.
  rewrite <- bbang_bneg_or.
  rewrite -CleqNgt -CgeqNlt.
  Ent_LR_rewrite_eq_e 0 (* ciph_len *).
  do 4 Ent_LR_subst_apply.
  Ent_L_contract_bbang 2.
  Bbang2sbang.
  Ent_L_sbang 0 => H1.
  Ent_L_sbang 0 => H2.
  Ent_R_sbang 0; last by [].
  rewrite -(ground_bexp_sem (@store0 _ sigma))in H1; apply bop_re_ge_Zge in H1.
  rewrite -(ground_bexp_sem (@store0 _ sigma))in H2; apply bop_re_le_Zle in H2.
  rewrite 2!(ground_exp_sem (@store0 _ sigma)) -/ciph_len_value -/ciph_len_value_Z s2Z_ge_s_cst_e // in H1.
  rewrite 2!(ground_exp_sem (@store0 _ sigma)) -/ciph_len_value -/ciph_len_value_Z s2Z_ge_s_cst_e // in H2.
  lia.
move => Hciph_len_bound_Z.

have Hciph_len_bound_nat : 2 <= ciph_len_value_nat <= 256.
  rewrite [X in _ <= _ <= X](_ : 256%nat = Z.abs_nat 256) // [X in X < _ <= _](_ : 1%nat = Z.abs_nat 1) //.
  apply/andP; split.
    apply/ltP/Zabs_nat_lt; lia.
  apply/leP/Zabs_nat_le; lia.

pose Hciph_len_bound2'' := !!(Z<=nat compmeth + Z<=u BU2 `_ 51 + ciph_len_value_Z < the_n_plus5)%Z.
Hoare_L_stren_by Hciph_len_bound2'' (Hsess_len :: Hn_old :: Hciph_len :: Hciph_len_bound2 :: nil).
  unfold Hn_old, Hsess_len, Hciph_len, Hciph_len_bound2.
  Ent_LR_rewrite_eq_e 0 (* ciph_len *).
  do 4 Ent_LR_subst_apply.
  fold Hciph_len_bound2''.
  Ent_LR_rewrite_eq_e 0 (* sess_len *).
  do 3 Ent_LR_subst_apply.
  fold Hciph_len_bound2''.
  Ent_LR_rewrite_eq_e 0 (* n old *).
  do 2 Ent_LR_subst_apply.
  rewrite -/Shigh -/Slow -/ciph_len_exp.
  Bbang2sbang.
  apply ent_sbang_sbang.
  rewrite gb_bneg_bop_r_ge.
  move/Zlt_gb. move/(_ erefl erefl).
  rewrite si32_of_phy_gb_add_e si32_of_phy_gb_add_e si32_of_phy_gb_add_e ge_cast_sint_cst_8c.
  rewrite (phy_of_si32K (zext 24 BU2 `_ 51)) 3!i32_ge_s_cst_e -/ciph_len_value.
  have H1 : (0 <= Z<=nat compmeth + Z<=u BU2 `_ 51 + ciph_len_value_Z < 2 ^^ 31)%Z.
    split.
      apply (@leZ_trans (Z0 + Z0 + 2)) => //.
      apply leZ_add => //.
      apply leZ_add => //; exact: min_u2Z.
    by case: Hciph_len_bound_Z.
    apply (@leZ_ltZ_trans (Z<=nat compmeth + 2 ^^ 8 + 256)) => //.
    apply leZ_add.
      exact/leZ_add2l/ltZW/max_u2Z.
    by case: Hciph_len_bound_Z.
  have -> : (Z<=s ((Z2s 32 (Z<=nat compmeth) `+ zext 24 BU2 `_ 51) `+
        si32<=phy ciph_len_value) = Z<=nat compmeth + u2Z (BU2 `_ 51) + ciph_len_value_Z)%Z.
    rewrite s2Z_add; last first.
      rewrite s2Z_add; last first.
        rewrite Z2sK // (s2Z_zext 24) //.
        move: (min_u2Z BU2 `_ 51) => ?; lia.
      rewrite Z2sK // (s2Z_zext 24) // -/ciph_len_value_Z; lia.
    rewrite s2Z_add; last first.
      rewrite Z2sK // (s2Z_zext 24) //.
      move: (min_u2Z BU2 `_ 51) => ?; lia.
    by rewrite Z2sK // (s2Z_zext 24).
  rewrite s2Z_add; last first.
    rewrite Z2sK // Z2sK; last by simpl expZ; lia.
    simpl expZ; lia.
  rewrite Z2sK // Z2sK; last by simpl expZ; lia.
  apply.
  exact H1.
  simpl expZ; lia.

apply hoare_pullout_sbang => Hciph_len_bound2'.
clear Hciph_len_bound2''.
Hoare_L_contract_bbang Hciph_len_bound2; clear Hciph_len_bound2.

(** _comp_len' <-* __buf \+ ([ 41 ]sc \+ __sess_len \+ __ciph_len); *)

idtac "51) lookup".

pose comp_len'_exp : exp sigma (ityp: uchar) := [ BU2 `_ (54 + u2nat (BU2 `_ 51) + ciph_len_value_nat) ]pc.
pose comp_len'_value := @ground_exp g sigma _ comp_len'_exp erefl.
pose comp_len'_value_nat := nat<=u (i8<=phy comp_len'_value).
pose Hcomp_len' := `! \b __comp_len' \= [comp_len'_value]c.
Hoare_seq_ext Hcomp_len'.
  Hoare_L_dup (Hsess_len :: Hsess_len_2 :: Hciph_len :: Hciph_len_bound::nil).
  unfold final_id, Final_id, final_rb, Final_rb.
  Hoare_frame (Hbu :: Hbuf :: Hsess_len :: Hsess_len_2 :: Hciph_len :: Hciph_len_bound :: nil)
    (Hbu :: Hbuf :: Hcomp_len' :: nil).
  apply hoare_lookup_mapstos_fit_stren with (i := 54 + u2nat (BU2 `_ 51) + ciph_len_value_nat) (l := map phy_of_ui8 BU2) (e := [ bu ]c).
  - rewrite size_map sizeof_ityp sz_BU2 sz_BU1 inj_mult sz_BU; by vm_compute.
  - apply ent_R_lookup_mapstos_fit_trans.
    + rewrite size_map sz_BU2 sz_BU1 sz_BU // /SSL_BUFFER_LEN -(_: '| 54 | = 54%nat) // /ciph_len_value_nat.
      move: (min_u2Z (BU2 `_ 51)) => ?.
      rewrite -!plusE -Zabs_nat_Zplus // -Zabs_nat_Zplus; last 2 first.
        apply addZ_ge0 => //; exact: min_u2Z.
        case: Hciph_len_bound_Z => Htmp _; by apply: leZ_trans; last by apply Htmp.
      apply/ltP; apply Zabs2Nat.inj_lt; lia.
    + unfold Hbu.
      Ent_decompose (0 :: nil) (1 :: nil); first by apply ent_id.
      rewrite /Hbuf /Hsess_len /Hciph_len /Hsess_len_2 /Hciph_len_bound -/ciph_len_exp.
      Ent_L_contract_bbang 2.
      Ent_L_contract_bbang 3.
      Ent_LR_rewrite_eq_p 0 (* buf *).
      do 2 Ent_LR_subst_apply.
      Ent_R_subst_con_distr.
      do 2 Ent_LR_subst_apply.
      Ent_LR_rewrite_eq_e 0 (* sess_len *).
      Ent_LR_subst_apply.
      Ent_R_subst_con_distr.
      do 2 Ent_LR_subst_apply.
      rewrite -/Slow -/Shigh -/ciph_len_exp.
      Ent_LR_rewrite_eq_e 0 (* ciph_len *).
      Ent_R_subst_con_distr.
      do 2 Ent_LR_subst_apply.
      Bbang2sbang.
      Ent_R_sbang 0; last by [].
      rewrite -(ground_bexp_sem (store0 sigma)).
      rewrite beval_eq_p_eq.
      clear -BU_51 Hciph_len_bound_Z.
      move: (min_u2Z (BU2 `_ 51)) => ?.
      have Hoverflow:
        (s2Z (si32<=phy (ground_exp ([ 41 ]sc \+ (int) ([ BU2 `_ 51 ]pc : exp sigma (ityp: uchar)) \+ ciph_len_exp) erefl)) =
         41 + u2Z (BU2 `_ 51) + s2Z (si32<=phy (ground_exp ciph_len_exp erefl)))%Z.
        rewrite 2!si32_of_phy_gb_add_e (@i32_ge_s_cst_e g sigma) ge_cast_sint_cst_8c.
        rewrite phy_of_si32K 2!s2Z_add Z2sK // (s2Z_zext 24) // -/ciph_len_value_Z; simpl expZ; lia.
      case: Hciph_len_bound_Z => H H0.
      rewrite eval_add_pA; first last.
      - rewrite Hoverflow sizeof_ityp [sizeof_integral _]/= 2!mul1Z si32_of_phy_sc Z2sK // -/ciph_len_value_Z.
        simpl expZ; lia.
      - rewrite Hoverflow sizeof_ityp [sizeof_integral _]/= mul1Z -/ciph_len_value_Z.
        simpl expZ; lia.
      - by rewrite sizeof_ityp [sizeof_integral _]/= mul1Z si32_of_phy_sc Z2sK.
      rewrite -beval_eq_p_eq.
      apply Ceqpn_add2l'.
      rewrite beval_eq_e_eq.
      apply/eqP/si32_of_phy_inj.
      rewrite 3!si32_of_phy_binop_ne 3!si32_of_phy_sc.
      apply s2Z_inj.
      rewrite (ground_exp_sem (store0 sigma)) (@ge_cast_sint_cst_8c g sigma) phy_of_si32K // Z2sK; last first.
        rewrite 2!inj_plus Z_of_nat_Zabs_nat; last by apply min_u2Z.
        rewrite (_ : Z<=nat 54 = 54%Z) // /ciph_len_value_Z Z_of_nat_Zabs_nat; simpl expZ; lia.
      rewrite s2Z_add Z2sK // s2Z_add // -/ciph_len_value_Z s2Z_add Z2sK // (s2Z_zext 24) //; try by simpl expZ; lia.
      rewrite !inj_plus Z_of_nat_Zabs_nat; last by apply min_u2Z.
      rewrite /ciph_len_value_nat (_ : Z<=nat 54 = 54%Z) // Z_of_nat_Zabs_nat; last by lia.
      ring.
  + Ent_R_subst_con_distr.
    rewrite [nth]lock.
    do 3 Ent_LR_subst_apply.
    Ent_decompose (0 :: 1 :: nil) (0 :: 1 :: nil); first by apply ent_id.
    do 4 Ent_L_contract_bbang 0.
    Bbang2sbang.
    Ent_R_sbang 0; last by [].
    rewrite -lock gb_eq_e; apply/eqP.
    rewrite /comp_len'_value /comp_len'_exp 3!ge_cst_e (nth_map (Z2u 8 0)) // sz_BU2 sz_BU1 sz_BU /SSL_BUFFER_LEN.
    apply ltn_trans with (54 + 32 + 256 + 1); last by vm_compute.
    rewrite -!addnA ltn_add2l ltn_leq_add2l // -(addn0 ciph_len_value_nat) ltn_leq_add2l //.
    by case/andP : Hciph_len_bound_nat.

(** _comp_len <- (int) __comp_len'; *)

idtac "52) assign".

pose comp_len_exp := (int) ([ BU2 `_ (54 + u2nat (BU2 `_ 51) + ciph_len_value_nat) ]pc : exp sigma (ityp: uchar)).
pose comp_len_value := @ground_exp _ sigma _ comp_len_exp erefl.
pose Hcomp_len := `! \b __comp_len \= [comp_len_value]c.
Hoare_seq_ext Hcomp_len.
  Hoare_L_dup (Hcomp_len' :: nil).
  unfold final_id, Final_id, final_rb, Final_rb.
  Hoare_frame (Hcomp_len' :: nil) (Hcomp_len :: nil).
  apply hoare_assign_stren.
  unfold Hcomp_len, Hcomp_len'.
  Ent_LR_subst_apply.
  Ent_LR_rewrite_eq_e 0 (* comp_len'*).
  Ent_LR_subst_apply.
  Bbang2sbang; Ent_R_sbang 0; last by [].
  unfold comp_len_value, comp_len'_value.
  Rewrite_ground_bexp @sequiv_ge.
  Rewrite_ground_bexp @sequiv_ge.
  Rewrite_ground_bexp @beq_exx.
  exact: oneuc.

(** IIf  \b __comp_len \< [ 1 ]sc \|| __comp_len \> [ 16 ]sc \||
          [ Z<=nat 47 ]sc \+ __sess_len \+ __ciph_len \+ __comp_len \!=
          [ 5 ]sc \+ __n_old  Then *)
(**   _ret <- [ POLARSSL_ERR_SSL_BAD_HS_CLIENT_HELLO ]c; Return *)

idtac "53) ifte".
apply hoare_ifte_bang; first by apply POLAR_ret_err.
rewrite -bbang_bneg_or.
set Hextensions := `! \~b \b [ Z<=nat compmeth.+1 ]sc \+ __sess_len \+ __ciph_len \+ __comp_len \!= [ 5 ]sc \+ __n_old.

Hoare_L_contract_bbang Hcomp_len'.
clear Hcomp_len' comp_len'_value comp_len'_exp comp_len'_value_nat.

(** "_goto_have_cipher_" <- [ 0 ]sc; *)

idtac "54) assign".

pose H_goto_have_cipher := `! \b __goto_have_cipher \= [ 0 ]sc.
Hoare_seq_ext H_goto_have_cipher.
  Hoare_frame (@nil assert) (H_goto_have_cipher :: nil).
  apply hoare_assign_stren.
  Ent_LR_subst_apply.
  Bbang2sbang.
  Ent_R_sbang 0; last by [].
  Rewrite_ground_bexp @sequiv_bop_re_sc => //=.
  exact: oneuc.

idtac "before apply POLAR_parse_client_hello_triple3".

by apply POLAR_parse_client_hello_triple3 with (BU := BU) (in_left0 := in_left) (BU1 := BU1).
Qed.

End POLAR_parse_client_hello_triple.