Require Import VST.floyd.proofauto.
Import ListNotations.
Local Open Scope logic.
Require Import VST.floyd.sublist.

Require Import sha.HMAC256_functional_prog.
Require Import sha.general_lemmas.
Require Import sha.spec_sha.

Require Import hmacdrbg.entropy.
Require Import hmacdrbg.entropy_lemmas.
Require Import hmacdrbg.DRBG_functions.
Require Import hmacdrbg.HMAC_DRBG_algorithms.
Require Import hmacdrbg.HMAC256_DRBG_functional_prog.
Require Import hmacdrbg.hmac_drbg.
Require Import hmacdrbg.HMAC_DRBG_pure_lemmas.
Require Import hmacdrbg.spec_hmac_drbg.
Require Import hmacdrbg.HMAC_DRBG_common_lemmas.
Require Import hmacdrbg.spec_hmac_drbg_pure_lemmas.
Require Import VST.floyd.library.

Require Import hmacdrbg.verif_hmac_drbg_seed_common.

Module Instantiate_eq.

Definition OptionalNonce: option (list Z) := None. (*The implementation takes nonce from entropy, using the el*3/2 calculation*)

(*NIST, Section 10.1: highest supported sec strength is given by the hash function's
security strength for preimage resistance. For SHA256, this is
(according to NIST SP 800-107, Table 1, page 11) 256 bits. See also Appendix B2 of NIST SP 800-90A. *)
Definition highest_supported_security_strength := 32. (* in bytes -- see comment for reseed*)

(*Q: should we use the sec strength of HMAC, calculated according to Section 5.3.4 of
NIST SP 800-107 instead?*)
Definition requested_security_strength:= 32.  (*same as in reseed*)

Definition prediction_resistance_supported:bool:=true.

Definition mbedtls_HMAC256_DRBG_instantiate_function (entropy_stream: ENTROPY.stream)
         entropy_len pr_flag (personalization_string: list Z): ENTROPY.result DRBG_state_handle :=
    HMAC256_DRBG_instantiate_function entropy_len entropy_len OptionalNonce
            highest_supported_security_strength max_personalization_string_length
            prediction_resistance_supported entropy_stream
            requested_security_strength pr_flag personalization_string.

Definition entlen:Z := 32.

Parameter Entropy_addSuccess1: forall n m s s1 l1 s2 l2,
        ENTROPY.get_bytes n s = ENTROPY.success l1 s1 ->
        ENTROPY.get_bytes m s1 = ENTROPY.success l2 s2 ->
        ENTROPY.get_bytes (n+m) s = ENTROPY.success (l1++l2) s2.

Parameter Entropy_addSuccess2: forall n m s s1 l1 s2 e,
        ENTROPY.get_bytes n s = ENTROPY.success l1 s1 ->
        ENTROPY.get_bytes m s1 = ENTROPY.error e s2 ->
        ENTROPY.get_bytes (n+m) s = ENTROPY.error e s2.

Parameter Entropy_addError: forall n m s s1 e, ENTROPY.get_bytes n s = ENTROPY.error e s1 ->
        ENTROPY.get_bytes (n+m) s = ENTROPY.error e s1.

Lemma Entropy_le n s l ss: ENTROPY.success l ss = ENTROPY.get_bytes n s ->
  forall m, (m <= n)%nat -> exists l' s', ENTROPY.success l' s' = ENTROPY.get_bytes m s.
Proof. intros.
  remember (ENTROPY.get_bytes m s) as d.
  destruct d. eexists; eexists; trivial.
  symmetry in H; symmetry in Heqd.
  specialize (Entropy_addError _ (n-m)%nat _ _ _ Heqd).
     rewrite le_plus_minus_r; trivial.
  intros HH; rewrite HH in *. discriminate.
Qed.

Lemma Entropy_addSuccess3: forall n m s ss l,
        ENTROPY.get_bytes n s = ENTROPY.success l ss -> (m <= n)%nat ->
        exists l1 s1, ENTROPY.get_bytes m s = ENTROPY.success l1 s1 /\
        exists l2, ENTROPY.get_bytes (n-m)%nat s1 = ENTROPY.success l2 ss /\ l=l1++l2.
Proof. intros.
  remember (ENTROPY.get_bytes m s). destruct r.
+ exists l0, s0; split; trivial.
  symmetry in Heqr.
  remember (ENTROPY.get_bytes (n-m)%nat s0) as t.
  destruct t; symmetry in Heqt.
  - specialize (Entropy_addSuccess1 m (n-m)%nat s s0). rewrite Heqr, Heqt, le_plus_minus_r; trivial.
    intros X. rewrite (X _ _ _ (eq_refl _) (eq_refl _)) in H; clear X Heqr Heqt. inv H. exists l1; split; trivial.
  - specialize (Entropy_addSuccess2 m (n-m)%nat s s0). rewrite Heqr, Heqt, le_plus_minus_r; trivial.
    intros X. rewrite (X _ _ _ (eq_refl _) (eq_refl _)) in H; clear X Heqr Heqt. inv H.
+ symmetry in Heqr; exfalso.
  specialize (Entropy_addError m (n-m)%nat s). rewrite Heqr, le_plus_minus_r; trivial.
  intros X. rewrite (X _ _ (eq_refl _)) in H. inv H.
Qed.

Lemma instantiate_eq es prflag pers:
      instantiate_function_256 es prflag pers =
      mbedtls_HMAC256_DRBG_instantiate_function es entlen prflag pers.
Proof. unfold instantiate_function_256, mbedtls_HMAC256_DRBG_instantiate_function,
   HMAC256_DRBG_instantiate_function, DRBG_instantiate_function, HMAC256_DRBG_instantiate_algorithm; simpl; intros.
destruct (Zlength pers >? max_personalization_string_length).
+ destruct prflag; trivial.
+ unfold entlen, get_entropy; simpl.
  remember (ENTROPY.get_bytes 48 es) as r.
  destruct r; symmetry in Heqr.
  - destruct (Entropy_addSuccess3 _ 32 _ _ _ Heqr) as [l1 [s1 [E32 [l2 [E16 L]]]]]. omega.
    simpl in E16. rewrite E32, E16; subst.
    unfold HMAC_DRBG_instantiate_algorithm. simpl. rewrite app_assoc. destruct prflag; trivial.
  - remember  (ENTROPY.get_bytes 32 es) as t; destruct t; symmetry in Heqt.
    * remember (ENTROPY.get_bytes 16 s0) as w; destruct w; symmetry in Heqw.
      ++ specialize (Entropy_addSuccess1 _ _ _ _ _ _ _ Heqt Heqw). simpl. rewrite Heqr. congruence.
      ++ specialize (Entropy_addSuccess2 _ _ _ _ _ _ _ Heqt Heqw). simpl. rewrite Heqr; intros X. inv X; destruct prflag; trivial.
    * specialize (Entropy_addError _ 16 _ _ _ Heqt). simpl. rewrite Heqr; intros X. inv X; destruct prflag; trivial.
Qed.

Lemma instantiate_reseed d s pr_flag rc ri (ZLc'256F : (Zlength d >? 256) = false):
      mbedtls_HMAC256_DRBG_instantiate_function s entlen pr_flag  d =
      mbedtls_HMAC256_DRBG_reseed_function s (HMAC256DRBGabs initial_key initial_value rc 48 pr_flag ri) d.
Proof. rewrite <- instantiate256_reseed, instantiate_eq; trivial. Qed.

Opaque mbedtls_HMAC256_DRBG_reseed_function.
Opaque initial_key. Opaque initial_value.
Opaque mbedtls_HMAC256_DRBG_reseed_function.
Opaque list_repeat.

(*specification for the expected case, in which 0<=len<=256.
  But use mbedtls_HMAC256_DRBG_instantiate_function PROP of PRE and assume SUCCESS*)
Definition hmac_drbg_seed_simple_spec :=
  DECLARE _mbedtls_hmac_drbg_seed
   WITH dp:_, ctx: val, info:val, len: Z, data:val, Data: list Z,
        Ctx: hmac256drbgstate,
        kv: val, Info: md_info_state, s:ENTROPY.stream, rc:Z, pr_flag:bool, ri:Z,
        handle_ss: DRBG_state_handle * ENTROPY.stream
    PRE [_ctx OF tptr (Tstruct _mbedtls_hmac_drbg_context noattr),
         _md_info OF tptr (Tstruct _mbedtls_md_info_t noattr),
         _custom OF tptr tuchar, _len OF tuint ]
       PROP (len = Zlength Data /\ 0 <= len <=256 /\ Forall isbyteZ Data /\
             mbedtls_HMAC256_DRBG_instantiate_function s entlen pr_flag
                                       (contents_with_add data (Zlength Data) Data)
             = ENTROPY.success (fst handle_ss) (snd handle_ss))
       LOCAL (temp _ctx ctx; temp _md_info info;
              temp _len (Vint (Int.repr len)); temp _custom data; gvar sha._K256 kv)
       SEP (
         data_at Tsh t_struct_hmac256drbg_context_st Ctx ctx;
         preseed_relate dp rc pr_flag ri Ctx;
         data_at Tsh t_struct_mbedtls_md_info Info info;
         da_emp Tsh (tarray tuchar (Zlength Data)) (map Vint (map Int.repr Data)) data;
         K_vector kv; Stream s)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp (Vint ret_value))
       SEP (data_at Tsh t_struct_mbedtls_md_info Info info;
            da_emp Tsh (tarray tuchar (Zlength Data)) (map Vint (map Int.repr Data)) data;
            K_vector kv;
            if Int.eq ret_value (Int.repr (-20864))
            then data_at Tsh t_struct_hmac256drbg_context_st Ctx ctx *
                 preseed_relate dp rc pr_flag ri Ctx * Stream s
            else md_empty (fst Ctx) *
                 EX p:val, malloc_token Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
                 match (fst Ctx, fst handle_ss) with ((M1, (M2, M3)), ((((newV, newK), newRC), newEL), newPR))
                   => let CtxFinal := ((info, (M2, p)), (map Vint (map Int.repr newV), (Vint (Int.repr newRC), (Vint (Int.repr 32), (Val.of_bool newPR, Vint (Int.repr 10000)))))) in
                      !!(ret_value = Int.zero)
                      && data_at Tsh t_struct_hmac256drbg_context_st CtxFinal ctx *
                         hmac256drbg_relate (HMAC256DRBGabs newK newV newRC 32 newPR 10000) CtxFinal *
                         Stream (snd handle_ss)
                end).

Lemma body_hmac_drbg_seed_simple: semax_body HmacDrbgVarSpecs HmacDrbgFunSpecs
      f_mbedtls_hmac_drbg_seed hmac_drbg_seed_simple_spec.
Proof.
  start_function.
  abbreviate_semax.
  destruct H as [HDlen1 [HDlen2 [HData RES]]]. destruct handle_ss as [handle ss]. simpl in RES.
  rewrite data_at_isptr with (p:=ctx). Intros.
  destruct ctx; try contradiction.
  unfold_data_at 1%nat.
  destruct Ctx as [MdCTX [V [RC [EL [PR RI]]]]]. simpl.
  destruct MdCTX as [M1 [M2 M3]].
  freeze [1;2;3;4;5] FIELDS.
  rewrite field_at_compatible'. Intros. rename H into FC_mdx.
  rewrite field_at_data_at. unfold field_address. simpl. rewrite if_true; trivial. rewrite ptrofs_add_repr_0_r.
  freeze [0;2;3;4;5;6] FR0.
  Time forward_call ((M1,(M2,M3)), Vptr b i, Vint (Int.repr 1), info).

  Intros v. rename H into Hv.
  freeze [0] FR1. forward. thaw FR1.
  forward_if (
     PROP (v=0)
   LOCAL (temp _ret (Vint (Int.repr v)); temp _t'2 (Vint (Int.repr v));
   temp _ctx (Vptr b i); temp _md_info info; temp _len (Vint (Int.repr len));
   temp _custom data; gvar sha._K256 kv)
   SEP ( (EX p : val, !!malloc_compatible (sizeof (Tstruct _hmac_ctx_st noattr)) p &&
          memory_block Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
          malloc_token Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
          data_at Tsh (Tstruct _mbedtls_md_context_t noattr) (info,(M2,p)) (Vptr b i));
         FRZL FR0)).
  { destruct Hv; try omega. rewrite if_false; trivial. clear H. subst v.
    forward. simpl. Exists (Int.repr (-20864)).
    rewrite Int.eq_true.
    entailer!. thaw FR0. cancel.
    unfold_data_at 2%nat. thaw FIELDS. cancel.
    rewrite field_at_data_at. simpl.
    unfold field_address. rewrite if_true; simpl; trivial. rewrite ptrofs_add_repr_0_r; trivial. }
  { subst v. clear Hv. simpl. forward. entailer!. }
  Intros. subst v. clear Hv. Intros p. rename H into MCp. simpl in MCp.

  (*Alloction / md_setup succeeded. Now get md_size*)
  deadvars!. (*
  drop_LOCAL 0%nat.
  drop_LOCAL 0%nat.*)
  forward_call tt.

  (*call mbedtls_md_hmac_starts( &ctx->md_ctx, ctx->V, md_size )*)
  thaw FR0. subst.
  assert (ZL_VV: Zlength initial_key =32) by reflexivity.
  thaw FIELDS.
  freeze [4;5;6;7] FIELDS1.
  rewrite field_at_compatible'. Intros. rename H into FC_V.
  rewrite field_at_data_at. unfold field_address. simpl. rewrite if_true; trivial.
  rewrite <- ZL_VV.
  freeze [0;2;5;6;7;9] FR2.
  replace_SEP 1 (UNDER_SPEC.EMPTY p).
  { entailer!.
    eapply derives_trans. 2: apply UNDER_SPEC.mkEmpty.
    rewrite data_at__memory_block. simpl. entailer!.
  }
  forward_call (Vptr b i, ((info,(M2,p)):mdstate), 32, initial_key, kv, b, Ptrofs.add i (Ptrofs.repr 12)).
  { simpl. cancel. }
  { split; trivial. red. simpl. rewrite int_max_signed_eq.
    split. trivial. split. omega. rewrite two_power_pos_equiv.
    replace (2^64) with 18446744073709551616. omega. reflexivity.
    apply isbyteZ_initialKey.
  }
  Intros. clear H.

  (*call  memset( ctx->V, 0x01, md_size )*)
  freeze [0;1;3;4] FR3.
  forward_call (Tsh, Vptr b (Ptrofs.add i (Ptrofs.repr 12)), 32, Int.one).
  { rewrite sepcon_comm. apply sepcon_derives.
     - apply data_at_memory_block.
     - cancel. }

  (*ctx->reseed_interval = MBEDTLS_HMAC_DRBG_RESEED_INTERVAL;*)
  rewrite ZL_VV.
  thaw FR3. thaw FR2. unfold md_relate. simpl.
  replace_SEP 2 (field_at Tsh t_struct_hmac256drbg_context_st [StructField _md_ctx] (info, (M2, p)) (Vptr b i)). {
    entailer!. rewrite field_at_data_at.
    simpl. rewrite field_compatible_field_address by auto with field_compatible. simpl.
    rewrite ptrofs_add_repr_0_r.
    cancel.
  }
  thaw FIELDS1. forward.
  freeze [0;4;5;6;7] FIELDS2.
  freeze [0;1;2;3;4;5;6;7;8;9] ALLSEP.

  forward_if
  (PROP ( )
   LOCAL (temp _md_size (Vint (Int.repr 32)); temp _ctx (Vptr b i); temp _md_info info;
   temp _len (Vint (Int.repr (Zlength Data))); temp _custom data; gvar sha._K256 kv;
   temp _t'4 (Vint (Int.repr 32)))
   SEP (FRZL ALLSEP)).
  { elim H; trivial. }
  { clear H.
    forward_if.
    + elim H; trivial.
    + clear H. forward. forward. entailer!. }
  forward. simpl. deadvars!. (*drop_LOCAL 7%nat. _t'4*)

  (*NEXT INSTRUCTION:  ctx->entropy_len = entropy_len * 3 / 2*)
  thaw ALLSEP. thaw FIELDS2. forward.

  assert (FOURTYEIGHT: Int.unsigned (Int.mul (Int.repr 32) (Int.repr 3)) / 2 = 48).
  { rewrite mul_repr. simpl.
    rewrite Int.unsigned_repr. reflexivity. rewrite int_max_unsigned_eq; omega. }
  set (myABS := HMAC256DRBGabs initial_key initial_value rc 48 pr_flag 10000) in *.
  assert (myST: exists ST:hmac256drbgstate, ST =
    ((info, (M2, p)), (map Vint (list_repeat 32 Int.one), (Vint (Int.repr rc),
        (Vint (Int.repr 48), (Val.of_bool pr_flag, Vint (Int.repr 10000))))))). eexists; reflexivity.
  destruct myST as [ST HST].

  freeze [0;1;2;3;4] FR_CTX.
  freeze [3;4;6;7;8] KVStreamInfoDataFreeBlk.

  (*NEXT INSTRUCTION: mbedtls_hmac_drbg_reseed( ctx, custom, len ) *)
  freeze [1;2;3] INI.
  specialize (Forall_list_repeat isbyteZ 32 1); intros IB1.
  replace_SEP 0 (
         data_at Tsh t_struct_hmac256drbg_context_st ST (Vptr b i) *
         hmac256drbg_relate myABS ST).
  { entailer!. thaw INI. clear - FC_V IB1. (*KVStreamInfoDataFreeBlk.*) thaw FR_CTX.
    apply andp_right. apply prop_right. repeat split; trivial. apply IB1. split; omega.
    unfold_data_at 2%nat.
    cancel. unfold md_full; simpl.
    rewrite field_at_data_at; simpl.
    unfold field_address. rewrite if_true; simpl; trivial.
    cancel.
    apply UNDER_SPEC.REP_FULL.
  }

  clear INI.
  thaw KVStreamInfoDataFreeBlk. freeze [3;7] OLD_MD.
  forward_call (Data, data, Zlength Data, Vptr b i, ST, myABS, kv, Info, s).
  { unfold hmac256drbgstate_md_info_pointer.
    subst ST; simpl. cancel.
  }
  { subst myABS; simpl. rewrite <- initialize.max_unsigned_modulus in *; rewrite ptrofs_max_unsigned_eq.
    split. omega. (* rewrite int_max_unsigned_eq; omega.*)
    split. reflexivity.
    split. reflexivity.
    split. omega.
    split. (*change Int.modulus with 4294967296.*) omega.
    split. (* change Int.modulus with 4294967296.*)
       unfold contents_with_add. if_tac. omega. rewrite Zlength_nil; omega.
    split. apply IB1. split; omega.
    assumption.
  }

  Intros v.
  assert (ZLc': Zlength (contents_with_add data (Zlength Data) Data) = 0 \/
                 Zlength (contents_with_add data (Zlength Data) Data) = Zlength Data).
         { unfold contents_with_add. if_tac. right; trivial. left; trivial. }
  forward.
  deadvars!.
  forward_if (
   PROP ( v = nullval)
   LOCAL (temp _ret v; temp _t'7 v;
   temp _entropy_len (Vint (Int.repr 32));
   temp _ctx (Vptr b i); gvar sha._K256 kv)
   SEP (reseedPOST v Data data (Zlength Data) s
          myABS (Vptr b i) Info kv ST; FRZL OLD_MD)).
  { rename H into Hv. forward. simpl. Exists v.
    apply andp_right. apply prop_right; split; trivial.
    unfold reseedPOST.

    remember ((zlt 256 (Zlength Data) || zlt 384 (hmac256drbgabs_entropy_len myABS + Zlength Data)) %bool) as d.
    unfold myABS in Heqd; simpl in Heqd.
    destruct (zlt 256 (Zlength Data)); simpl in Heqd.
    + omega.
    + destruct (zlt 384 (48 + Zlength Data)); simpl in Heqd; try omega.
      subst d.
      unfold hmac256drbgstate_md_info_pointer, hmac256drbg_relate; simpl. Intros.
      rename H into RV.
      remember (mbedtls_HMAC256_DRBG_reseed_function s myABS
         (contents_with_add data (Zlength Data) Data)) as MRS.
      rewrite (ReseedRes _ _ _ RV). cancel.
      unfold return_value_relate_result in RV.
      assert (ZLc'256F: Zlength (contents_with_add data (Zlength Data) Data) >? 256 = false).
      { apply Zgt_is_gt_bool_f. destruct ZLc' as [ZLc' | ZLc']; rewrite ZLc'; trivial. omega. }
      unfold hmac256drbgabs_common_mpreds, hmac256drbgstate_md_info_pointer.
      destruct MRS.
      - exfalso. inv RV. simpl in Hv. discriminate.
      - simpl. Intros. Exists p. thaw OLD_MD. cancel.
        subst myABS. rewrite <- instantiate_reseed in HeqMRS; trivial.
        rewrite RES in HeqMRS. inv HeqMRS.
  }
  { rename H into Hv. forward. entailer!.
    apply negb_false_iff in Hv.
    symmetry in Hv; apply binop_lemmas2.int_eq_true in Hv; subst v. trivial.
  }
  deadvars!. Intros. subst v.
  unfold reseedPOST.
  remember ((zlt 256 (Zlength Data)
          || zlt 384 (hmac256drbgabs_entropy_len myABS + Zlength Data))%bool) as d.
  destruct d; Intros.
  remember (mbedtls_HMAC256_DRBG_reseed_function s myABS
         (contents_with_add data (Zlength Data) Data)) as MRS.
  unfold hmac256drbgabs_reseed. rewrite <- HeqMRS. subst myABS; simpl.

  assert (ZLc'256F: Zlength (contents_with_add data (Zlength Data) Data) >? 256 = false).
      { destruct ZLc' as [HH | HH]; rewrite HH. reflexivity.
        apply Zgt_is_gt_bool_f. omega. }
  rewrite <- instantiate_reseed, RES in HeqMRS; trivial. subst MRS. clear H RES Heqd.
  destruct handle as [[[[newV newK] newRC] dd] newPR].
  unfold hmac256drbgabs_common_mpreds. simpl. subst ST. unfold hmac256drbgstate_md_info_pointer. simpl. Intros.
  unfold_data_at 1%nat. freeze [0;1;2;4;5;6;7;8;9;10;11;12;13] ALLSEP.
  forward. forward.
  Exists Int.zero. simpl.
  apply andp_right. apply prop_right; split; trivial.
  thaw ALLSEP. thaw OLD_MD. Exists p.
  cancel;  normalize.
  apply andp_right. solve [apply prop_right; repeat split; trivial].
  cancel.
  unfold_data_at 1%nat. cancel.
  apply hmac_interp_empty.
Time Qed. (*Coq8.6: 26secs*)

(*Spec that does not assume len<=256 and includes a clause
  for the case where mbedtls_HMAC256_DRBG_instantiate_function yields
  Entropy.ERROR, ie no hypothesis about mbedtls_HMAC256_DRBG_instantiate_function in PROP of PRE*)
Definition hmac_drbg_seed_full_spec :=
  DECLARE _mbedtls_hmac_drbg_seed
   WITH dp:_, ctx: val, info:val, len: Z, data:val, Data: list Z,
        Ctx: hmac256drbgstate,
        kv: val, Info: md_info_state, s:ENTROPY.stream, rc:Z, pr_flag:bool, ri:Z
    PRE [_ctx OF tptr (Tstruct _mbedtls_hmac_drbg_context noattr),
         _md_info OF tptr (Tstruct _mbedtls_md_info_t noattr),
         _custom OF tptr tuchar, _len OF tuint ]
       PROP ( (len = Zlength Data) /\
              0 <= len /\
              48 + len < Int.modulus /\
              0 < 48 + Zlength (contents_with_add data len Data) < Int.modulus /\ Forall isbyteZ Data)
       LOCAL (temp _ctx ctx; temp _md_info info;
              temp _len (Vint (Int.repr len)); temp _custom data; gvar sha._K256 kv)
       SEP (
         data_at Tsh t_struct_hmac256drbg_context_st Ctx ctx;
         preseed_relate dp rc pr_flag ri Ctx;
         data_at Tsh t_struct_mbedtls_md_info Info info;
         da_emp Tsh (tarray tuchar (Zlength Data)) (map Vint (map Int.repr Data)) data;
         K_vector kv; Stream s)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp (Vint ret_value))
       SEP (data_at Tsh t_struct_mbedtls_md_info Info info;
            da_emp Tsh (tarray tuchar (Zlength Data)) (map Vint (map Int.repr Data)) data;
            K_vector kv;
            if Int.eq ret_value (Int.repr (-20864))
            then data_at Tsh t_struct_hmac256drbg_context_st Ctx ctx *
                 preseed_relate dp rc pr_flag ri Ctx * Stream s
            else md_empty (fst Ctx) *
                 EX p:val, malloc_token Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
                 match (fst Ctx) with (M1, (M2, M3)) =>
                   if (zlt 256 (Zlength Data) || (zlt 384 (48 + Zlength Data)))%bool
                   then !!(ret_value = Int.repr (-5)) &&
                     (Stream s *
                     ( let CtxFinal:= ((info, (M2, p)), (list_repeat 32 (Vint Int.one), (Vint (Int.repr rc),
                                       (Vint (Int.repr 48), (Val.of_bool pr_flag, Vint (Int.repr 10000)))))) in
                       let CTXFinal:= HMAC256DRBGabs initial_key initial_value rc 48 pr_flag 10000 in
                       data_at Tsh t_struct_hmac256drbg_context_st CtxFinal ctx *
                                     hmac256drbg_relate CTXFinal CtxFinal))

                   else match mbedtls_HMAC256_DRBG_instantiate_function s entlen pr_flag
                                       (contents_with_add data (Zlength Data) Data)
                        with
                         | ENTROPY.error e ss =>
                            (!!(match e with
                               | ENTROPY.generic_error => Vint ret_value = Vint (Int.repr ENT_GenErr)
                               | ENTROPY.catastrophic_error => Vint ret_value = Vint (Int.repr (-9))
                              end) && (Stream ss *
                                       let CtxFinal:= ((info, (M2, p)), (list_repeat 32 (Vint Int.one), (Vint (Int.repr rc),
                                                (Vint (Int.repr 48), (Val.of_bool pr_flag, Vint (Int.repr 10000)))))) in
                                       let CTXFinal:= HMAC256DRBGabs initial_key initial_value rc 48 pr_flag 10000 in
                                       data_at Tsh t_struct_hmac256drbg_context_st CtxFinal ctx *
                                       hmac256drbg_relate CTXFinal CtxFinal))
                        | ENTROPY.success handle ss => !!(ret_value = Int.zero) &&
                                    match handle with ((((newV, newK), newRC), newEL), newPR) =>
                                      let CtxFinal := ((info, (M2, p)), (map Vint (map Int.repr newV), (Vint (Int.repr newRC), (Vint (Int.repr 32), (Val.of_bool newPR, Vint (Int.repr 10000)))))) in
                                      let CTXFinal := HMAC256DRBGabs newK newV newRC 32 newPR 10000 in
                                    data_at Tsh t_struct_hmac256drbg_context_st CtxFinal ctx *
                                    hmac256drbg_relate CTXFinal CtxFinal *
                                    Stream ss end
                        end
                end).

Lemma body_hmac_drbg_seed_full: semax_body HmacDrbgVarSpecs HmacDrbgFunSpecs
      f_mbedtls_hmac_drbg_seed hmac_drbg_seed_full_spec.
Proof.
  start_function.
  abbreviate_semax.
  destruct H as (*[PREQ*) [HDlen1 [HDlen2 [DHlen3 [DHlen4 HData]]]](*]*).
  rewrite data_at_isptr with (p:=ctx). Intros.
  destruct ctx; try contradiction.
  unfold_data_at 1%nat.
  destruct Ctx as [MdCTX [V [RC [EL [PR RI]]]]]. simpl.
  destruct MdCTX as [M1 [M2 M3]].
  freeze [1;2;3;4;5] FIELDS.
  rewrite field_at_compatible'. Intros. rename H into FC_mdx.
  rewrite field_at_data_at. unfold field_address. simpl. rewrite if_true; trivial. rewrite ptrofs_add_repr_0_r.
  freeze [0;2;3;4;5;6] FR0.
  Time forward_call ((M1,(M2,M3)), Vptr b i, Vint (Int.repr 1), info).

  Intros v. rename H into Hv.
  freeze [0] FR1. forward. thaw FR1.
  deadvars!.
  forward_if (
     PROP (v=0)
   LOCAL (temp _ret (Vint (Int.repr v)); temp _t'2 (Vint (Int.repr v));
   temp _ctx (Vptr b i); temp _md_info info; temp _len (Vint (Int.repr len));
   temp _custom data; gvar sha._K256 kv)
   SEP ( (EX p : val, !!malloc_compatible (sizeof (Tstruct _hmac_ctx_st noattr)) p &&
          memory_block Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
          malloc_token Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
          data_at Tsh (Tstruct _mbedtls_md_context_t noattr) (info,(M2,p)) (Vptr b i));
         FRZL FR0)).
  { destruct Hv; try omega. rewrite if_false; trivial. clear H. subst v.
    forward. simpl. Exists (Int.repr (-20864)).
    rewrite Int.eq_true.
    entailer!. thaw FR0. cancel.
    unfold_data_at 2%nat. thaw FIELDS. cancel.
    rewrite field_at_data_at. simpl.
    unfold field_address. rewrite if_true; simpl; trivial. rewrite ptrofs_add_repr_0_r; trivial. }
  { subst v. clear Hv. simpl. forward. entailer!. }
  Intros. subst v. clear Hv. Intros p. rename H into MCp. simpl in MCp.

  (*Alloction / md_setup succeeded. Now get md_size*)
  deadvars!.
  forward_call tt.

  (*call mbedtls_md_hmac_starts( &ctx->md_ctx, ctx->V, md_size )*)
  thaw FR0. subst.
  assert (ZL_VV: Zlength initial_key =32) by reflexivity.
  thaw FIELDS.
  freeze [4;5;6;7] FIELDS1.
  rewrite field_at_compatible'. Intros. rename H into FC_V.
  rewrite field_at_data_at. unfold field_address. simpl. rewrite if_true; trivial.
  rewrite <- ZL_VV.
  freeze [0;2;5;6;7;9] FR2.
  replace_SEP 1 (UNDER_SPEC.EMPTY p).
  { entailer!.
    eapply derives_trans. 2: apply UNDER_SPEC.mkEmpty.
    rewrite data_at__memory_block. simpl. entailer!.
  }
  forward_call (Vptr b i, ((info,(M2,p)):mdstate), 32, initial_key, kv, b, Ptrofs.add i (Ptrofs.repr 12)).
  { simpl. cancel. }
  { split; trivial. red. simpl. rewrite int_max_signed_eq.
    split. trivial. split. omega. rewrite two_power_pos_equiv.
    replace (2^64) with 18446744073709551616. omega. reflexivity.
    apply isbyteZ_initialKey.
  }
  Intros. clear H.

  (*call  memset( ctx->V, 0x01, md_size )*)
  freeze [0;1;3;4] FR3.
  forward_call (Tsh, Vptr b (Ptrofs.add i (Ptrofs.repr 12)), 32, Int.one).
  { rewrite sepcon_comm. apply sepcon_derives.
     - apply data_at_memory_block.
     - cancel. }

  (*ctx->reseed_interval = MBEDTLS_HMAC_DRBG_RESEED_INTERVAL;*)
  rewrite ZL_VV.
  thaw FR3. thaw FR2. unfold md_relate. simpl.
  replace_SEP 2 (field_at Tsh t_struct_hmac256drbg_context_st [StructField _md_ctx] (info, (M2, p)) (Vptr b i)). {
    entailer!. rewrite field_at_data_at.
    simpl. rewrite field_compatible_field_address by auto with field_compatible. simpl.
    rewrite ptrofs_add_repr_0_r.
    cancel.
  }
  deadvars!.
  thaw FIELDS1. forward.
  freeze [0;4;5;6;7] FIELDS2.
  freeze [0;1;2;3;4;5;6;7;8;9] ALLSEP.

  forward_if
  (PROP ( )
   LOCAL (temp _md_size (Vint (Int.repr 32)); temp _ctx (Vptr b i);
   temp _len (Vint (Int.repr (Zlength Data))); temp _custom data; gvar sha._K256 kv;
   temp _t'4 (Vint (Int.repr 32)))
   SEP (FRZL ALLSEP)).
  { elim H; trivial. }
  { clear H.
    forward_if.
    + elim H; trivial.
    + clear H. forward. forward. entailer!. }
  forward. simpl. deadvars!. (*drop_LOCAL 7%nat. _t'4*)

  (*NEXT INSTRUCTION:  ctx->entropy_len = entropy_len * 3 / 2*)
  thaw ALLSEP. thaw FIELDS2. forward.

  assert (FOURTYEIGHT: Int.unsigned (Int.mul (Int.repr 32) (Int.repr 3)) / 2 = 48).
  { rewrite mul_repr. simpl.
    rewrite Int.unsigned_repr. reflexivity. rewrite int_max_unsigned_eq; omega. }
  set (myABS := HMAC256DRBGabs initial_key initial_value rc 48 pr_flag 10000) in *.
  assert (myST: exists ST:hmac256drbgstate, ST =
    ((info, (M2, p)), (map Vint (list_repeat 32 Int.one), (Vint (Int.repr rc),
        (Vint (Int.repr 48), (Val.of_bool pr_flag, Vint (Int.repr 10000))))))). eexists; reflexivity.
  destruct myST as [ST HST].

  freeze [0;1;2;3;4] FR_CTX.
  freeze [3;4;6;7;8] KVStreamInfoDataFreeBlk.

  (*NEXT INSTRUCTION: mbedtls_hmac_drbg_reseed( ctx, custom, len ) *)
  freeze [1;2;3] INI.
  specialize (Forall_list_repeat isbyteZ 32 1); intros IB1.
  replace_SEP 0 (
         data_at Tsh t_struct_hmac256drbg_context_st ST (Vptr b i) *
         hmac256drbg_relate myABS ST).
  { entailer!. thaw INI. clear - FC_V IB1. (*KVStreamInfoDataFreeBlk.*) thaw FR_CTX.
    apply andp_right. apply prop_right. repeat split; trivial. apply IB1. split; omega.
    unfold_data_at 2%nat.
    cancel. unfold md_full; simpl.
    rewrite field_at_data_at; simpl.
    unfold field_address. rewrite if_true; simpl; trivial.
    cancel.
    apply UNDER_SPEC.REP_FULL.
  }

  clear INI.
  thaw KVStreamInfoDataFreeBlk. freeze [3;7] OLD_MD.
  forward_call (Data, data, Zlength Data, Vptr b i, ST, myABS, kv, Info, s).
  { unfold hmac256drbgstate_md_info_pointer.
    subst ST; simpl. cancel.
  }
  { subst myABS; simpl. rewrite <- initialize.max_unsigned_modulus in *.
    split. rep_omega. (* rewrite int_max_unsigned_eq; omega.*)
    split. reflexivity.
    split. reflexivity.
    split. omega.
    split. rep_omega.
    split. (* change Int.modulus with 4294967296.*)
       unfold contents_with_add. if_tac. rep_omega. rewrite Zlength_nil; rep_omega.
    split. apply IB1. split; omega.
    assumption.
  }

  Intros v.
  assert (ZLc': Zlength (contents_with_add data (Zlength Data) Data) = 0 \/
                 Zlength (contents_with_add data (Zlength Data) Data) = Zlength Data).
         { unfold contents_with_add. if_tac. right; trivial. left; trivial. }
  forward.
  deadvars!.
  forward_if (
   PROP ( v = nullval)
   LOCAL (temp _ret v; temp _t'7 v;
   temp _entropy_len (Vint (Int.repr 32)); temp _ctx (Vptr b i); gvar sha._K256 kv)
   SEP (reseedPOST v Data data (Zlength Data) s
          myABS (Vptr b i) Info kv ST; FRZL OLD_MD)).
  { rename H into Hv. forward. simpl. Exists v.
    apply andp_right. apply prop_right; split; trivial.
    unfold reseedPOST.

    remember ((zlt 256 (Zlength Data) || zlt 384 (hmac256drbgabs_entropy_len myABS + Zlength Data)) %bool) as d.
    unfold myABS in Heqd; simpl in Heqd.
    destruct (zlt 256 (Zlength Data)); simpl in Heqd.
    + subst d. unfold hmac256drbgstate_md_info_pointer, hmac256drbg_relate; simpl.
      simpl. subst myABS. normalize. cancel. simpl.
      Exists p. thaw OLD_MD. normalize.
      apply andp_right. apply prop_right; repeat split; trivial. cancel.
      apply hmac_interp_empty.
    + destruct (zlt 384 (48 + Zlength Data)); simpl in Heqd; try omega.
      subst d.
      unfold hmac256drbgstate_md_info_pointer, hmac256drbg_relate; simpl. Intros.
      rename H into RV.
      remember (mbedtls_HMAC256_DRBG_reseed_function s myABS
         (contents_with_add data (Zlength Data) Data)) as MRS.
      rewrite (ReseedRes _ _ _ RV). cancel.
      unfold return_value_relate_result in RV.
      assert (ZLc'256F: Zlength (contents_with_add data (Zlength Data) Data) >? 256 = false).
      { apply Zgt_is_gt_bool_f. destruct ZLc' as [ZLc' | ZLc']; rewrite ZLc'; trivial. omega. }
      unfold hmac256drbgabs_common_mpreds, hmac256drbgstate_md_info_pointer.
      destruct MRS.
      - exfalso. inv RV. simpl in Hv. discriminate.
      - simpl. Intros. Exists p. thaw OLD_MD. cancel.
        subst myABS. rewrite <- instantiate_reseed in HeqMRS; trivial.
        rewrite <- HeqMRS.
        normalize.
        apply andp_right. apply prop_right; repeat split; trivial.
        cancel. apply hmac_interp_empty.
  }
  { rename H into Hv. forward. entailer!.
    apply negb_false_iff in Hv.
    symmetry in Hv; apply binop_lemmas2.int_eq_true in Hv; subst v. trivial.
  }
  deadvars!. Intros. subst v.
  unfold reseedPOST.
  remember ((zlt 256 (Zlength Data)
          || zlt 384 (hmac256drbgabs_entropy_len myABS + Zlength Data))%bool) as d.
  destruct d; Intros.
  remember (mbedtls_HMAC256_DRBG_reseed_function s myABS
         (contents_with_add data (Zlength Data) Data)) as MRS.
  unfold hmac256drbgabs_reseed. rewrite <- HeqMRS. subst myABS; simpl.
  unfold return_value_relate_result in H.
  destruct MRS. Focus 2. exfalso. destruct e. inv H.
                     destruct ENT_GenErrAx as [EL1 _]. rewrite <- H in EL1. elim EL1; trivial.
  clear H.
  destruct d as [[[[newV newK] newRC] dd] newPR].
  unfold hmac256drbgabs_common_mpreds. simpl. subst ST. unfold hmac256drbgstate_md_info_pointer. simpl. Intros.
  unfold_data_at 1%nat. freeze [0;1;2;4;5;6;7;8;9;10;11;12] ALLSEP.
  forward. forward.
  Exists Int.zero. simpl.
  apply andp_right. apply prop_right; split; trivial.
  symmetry in Heqd. apply orb_false_iff in Heqd. destruct Heqd as [Heqd1 Heqd2].
  destruct (zlt 256 (Zlength Data)); try discriminate. simpl in *. rewrite Heqd2.
  thaw ALLSEP. thaw OLD_MD. Exists p. cancel.
  normalize.
  assert (ZLc'256F: Zlength (contents_with_add data (Zlength Data) Data) >? 256 = false).
      { destruct ZLc' as [HH | HH]; rewrite HH. reflexivity.
        apply Zgt_is_gt_bool_f. omega. }
  rewrite <- instantiate_reseed in HeqMRS; trivial.
  rewrite <- HeqMRS.
  normalize.
  apply andp_right. apply prop_right; repeat split; trivial.
  cancel.
  unfold_data_at 1%nat. cancel.
  apply hmac_interp_empty.
Time Qed. (*Coq8.6: 32secs*)
   (*Feb 22nd 2017: 245.406 secs (233.843u,0.203s) (successful)*)
   (*earlier: 69.671 secs (59.578u,0.015s) (successful)*)

End Instantiate_eq.

Lemma ReseedRes: forall X r v, @return_value_relate_result X r (Vint v) -> Int.eq v (Int.repr (-20864)) = false.
Proof. intros.
  unfold return_value_relate_result in H.
  destruct r. inv H; reflexivity.
  destruct e; inv H; try reflexivity.
  apply Int.eq_false. eapply ENT_GenErrAx.
Qed.

Definition preseed_relate V rc pr ri (r : hmac256drbgstate):mpred:=
    match r with
     (md_ctx', (V', (reseed_counter', (entropy_len', (prediction_resistance', reseed_interval'))))) =>
    md_empty md_ctx' &&
    !! (map Vint (map Int.repr V) = V' /\
        Zlength V = 32 /\
        Forall isbyteZ V /\
        Vint (Int.repr rc) = reseed_counter'(* /\
        Vint (Int.repr entropy_len) = entropy_len'*) /\
        Vint (Int.repr ri) = reseed_interval' /\
        Val.of_bool pr = prediction_resistance')
   end.

Definition hmac_drbg_seed_spec :=
  DECLARE _mbedtls_hmac_drbg_seed
   WITH ctx: val, info:val, len: Z, data:val, Data: list Z,
        Ctx: hmac256drbgstate,
        (*CTX: hmac256drbgabs,*)
        kv: val, Info: md_info_state, s:ENTROPY.stream, rc:Z, pr:bool, ri:Z, VV:list Z
    PRE [_ctx OF tptr (Tstruct _mbedtls_hmac_drbg_context noattr),
         _md_info OF tptr (Tstruct _mbedtls_md_info_t noattr),
         _custom OF tptr tuchar, _len OF tuint ]
       PROP ( (len = Zlength Data) /\
              0 <= len (*<= 336 Int.max_unsigned*) /\
              48 + len < Int.modulus /\
              0 < 48 + Zlength (contents_with_add data len Data) < Int.modulus /\ Forall isbyteZ Data)
       LOCAL (temp _ctx ctx; temp _md_info info;
              temp _len (Vint (Int.repr len)); temp _custom data; gvar sha._K256 kv)
       SEP (
         data_at Tsh t_struct_hmac256drbg_context_st Ctx ctx;
         preseed_relate VV rc pr ri Ctx;
         (*hmac256drbg_relate CTX Ctx;*)
         data_at Tsh t_struct_mbedtls_md_info Info info;
         da_emp Tsh (tarray tuchar (Zlength Data)) (map Vint (map Int.repr Data)) data;
         K_vector kv; Stream s)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp (Vint ret_value))
       SEP (data_at Tsh t_struct_mbedtls_md_info Info info;
            da_emp Tsh (tarray tuchar (Zlength Data)) (map Vint (map Int.repr Data)) data;
            K_vector kv;
            if Int.eq ret_value (Int.repr (-20864))
            then data_at Tsh t_struct_hmac256drbg_context_st Ctx ctx *
                  (*hmac256drbg_relate CTX Ctx *) preseed_relate VV rc pr ri Ctx *
                  Stream s
            else md_empty (fst Ctx) *
                 EX p:val, malloc_token Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
                 match (fst Ctx) with (M1, (M2, M3)) =>
                   if (zlt 256 (Zlength Data) || (zlt 384 ((*hmac256drbgabs_entropy_len initial_state_abs*)48 + Zlength Data)))%bool
                   then !!(ret_value = Int.repr (-5)) &&
                     (Stream s *
                     ( let CtxFinal:= ((info, (M2, p)), (list_repeat 32 (Vint Int.one), (Vint (Int.repr rc),
                                       (Vint (Int.repr 48), (Val.of_bool pr, Vint (Int.repr 10000)))))) in
                       let CTXFinal:= HMAC256DRBGabs VV (list_repeat 32 1) rc 48 pr 10000 in
                       data_at Tsh t_struct_hmac256drbg_context_st CtxFinal ctx *
                                     hmac256drbg_relate CTXFinal CtxFinal))

                   else let myABS := HMAC256DRBGabs VV (list_repeat 32 1) rc 48 pr 10000
                      in match mbedtls_HMAC256_DRBG_reseed_function s myABS
                                (contents_with_add data (Zlength Data) Data)
                         with
                         | ENTROPY.error e ss =>
                            (!!(match e with
                               | ENTROPY.generic_error => Vint ret_value = Vint (Int.repr ENT_GenErr)
                               | ENTROPY.catastrophic_error => Vint ret_value = Vint (Int.repr (-9))
                              end) && (Stream ss *
                                       let CtxFinal:= ((info, (M2, p)), (list_repeat 32 (Vint Int.one), (Vint (Int.repr rc),
                                                (Vint (Int.repr 48), (Val.of_bool pr, Vint (Int.repr 10000)))))) in
                                       let CTXFinal:= HMAC256DRBGabs VV (list_repeat 32 1) rc 48 pr 10000 in
                                       data_at Tsh t_struct_hmac256drbg_context_st CtxFinal ctx *
                                       hmac256drbg_relate CTXFinal CtxFinal))
                        | ENTROPY.success handle ss => !!(ret_value = Int.zero) &&
                                    match handle with ((((newV, newK), newRC), newEL), newPR) =>
                                      let CtxFinal := ((info, (M2, p)), (map Vint (map Int.repr newV), (Vint (Int.repr newRC), (Vint (Int.repr 32), (Val.of_bool newPR, Vint (Int.repr 10000)))))) in
                                      let CTXFinal := HMAC256DRBGabs newK newV newRC 32 newPR 10000 in
                                    data_at Tsh t_struct_hmac256drbg_context_st CtxFinal ctx *
                                    hmac256drbg_relate CTXFinal CtxFinal *
                                    Stream ss end
                        end
                end).

Opaque mbedtls_HMAC256_DRBG_reseed_function.

Lemma body_hmac_drbg_seed: semax_body HmacDrbgVarSpecs HmacDrbgFunSpecs
      f_mbedtls_hmac_drbg_seed hmac_drbg_seed_spec.
Proof.
  start_function.
  abbreviate_semax.
  destruct H as [HDlen1 [HDlen2 [DHlen3 [DHlen4 HData]]]].
  rewrite data_at_isptr with (p:=ctx). Intros.
  destruct ctx; try contradiction.
  unfold_data_at 1%nat.
  destruct Ctx as [MdCTX [V [RC [EL [PR RI]]]]]. simpl.
  destruct MdCTX as [M1 [M2 M3]].
  freeze [1;2;3;4;5] FIELDS.
  rewrite field_at_compatible'. Intros. rename H into FC_mdx.
  rewrite field_at_data_at. unfold field_address. simpl. rewrite if_true; trivial. rewrite ptrofs_add_repr_0_r.
  freeze [0;2;3;4;5;6] FR0.
  Time forward_call ((M1,(M2,M3)), Vptr b i, Vint (Int.repr 1), info).
  Intros v. rename H into Hv.
  freeze [0] FR1. forward. thaw FR1.

  forward_if (
     PROP (v=0)
   LOCAL (temp _ret (Vint (Int.repr v)); temp _t'2 (Vint (Int.repr v));
   temp _ctx (Vptr b i); temp _md_info info; temp _len (Vint (Int.repr len));
   temp _custom data; gvar sha._K256 kv)
   SEP ( (EX p : val, !!malloc_compatible (sizeof (Tstruct _hmac_ctx_st noattr))p &&
          memory_block Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
          malloc_token Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
          data_at Tsh (Tstruct _mbedtls_md_context_t noattr) (info,(M2,p)) (Vptr b i));
         FRZL FR0)).
  { destruct Hv; try omega. rewrite if_false; trivial. clear H. subst v.
    forward. simpl. Exists (Int.repr (-20864)).
    rewrite Int.eq_true.
    entailer!. thaw FR0. cancel.
    unfold_data_at 2%nat. thaw FIELDS. cancel.
    rewrite field_at_data_at. simpl.
    unfold field_address. rewrite if_true; simpl; trivial. rewrite ptrofs_add_repr_0_r; trivial. }
  { subst v. clear Hv. simpl. forward. entailer!. }
  Intros. subst v. clear Hv. Intros p. rename H into MCp.

  (*Alloction / md_setup succeeded. Now get md_size*)
  deadvars!.
  forward_call tt.

  (*call mbedtls_md_hmac_starts( &ctx->md_ctx, ctx->V, md_size )*)
  thaw FR0. subst.
  rename H1 into ZL_VV. rename H2 into isbyteZ_VV.
  thaw FIELDS.
  freeze [4;5;6;7] FIELDS1.
  rewrite field_at_compatible'. Intros. rename H into FC_V.
  rewrite field_at_data_at. unfold field_address. simpl. rewrite if_true; trivial.
  rewrite <- ZL_VV.
  freeze [0;2;5;6;7;9] FR2.
  replace_SEP 1 (UNDER_SPEC.EMPTY p).
  { entailer!.
    eapply derives_trans. 2: apply UNDER_SPEC.mkEmpty.
    rewrite data_at__memory_block. simpl. entailer!.
  }
  forward_call (Vptr b i, ((info,(M2,p)):mdstate), 32, VV, kv, b, Ptrofs.add i (Ptrofs.repr 12)).
  { rewrite ZL_VV, ptrofs_add_repr_0_r; simpl.
    apply prop_right; repeat split; trivial.
  }
  { simpl. cancel. }
  { split; trivial. red. simpl. rewrite int_max_signed_eq, ZL_VV.
    split. trivial. split. omega. rewrite two_power_pos_equiv.
    change (2^64) with 18446744073709551616. omega.
  }
  Intros.

  (*call  memset( ctx->V, 0x01, md_size )*)
  freeze [0;1;3;4] FR3.
  forward_call (Tsh, Vptr b (Ptrofs.add i (Ptrofs.repr 12)), 32, Int.one).
  { rewrite ZL_VV; entailer!.
  }
  { rewrite sepcon_comm. apply sepcon_derives.
      eapply derives_trans. apply data_at_memory_block.
        rewrite ZL_VV. simpl. cancel. cancel. }
  (*{ split. apply semax_call.writable_share_top.
    rewrite ZL_V0, client_lemmas.int_max_unsigned_eq. omega. }*)

  (*ctx->reseed_interval = MBEDTLS_HMAC_DRBG_RESEED_INTERVAL;*)
  rewrite ZL_VV.
  thaw FR3. thaw FR2. unfold md_relate. simpl.
  replace_SEP 2 (field_at Tsh t_struct_hmac256drbg_context_st [StructField _md_ctx] (info, (M2, p)) (Vptr b i)). {
    entailer!. rewrite field_at_data_at.
    simpl. rewrite field_compatible_field_address by auto with field_compatible. simpl.
    rewrite ptrofs_add_repr_0_r.
    cancel.
  }
  thaw FIELDS1. forward.
  freeze [0;4;5;6;7] FIELDS2.
  freeze [0;1;2;3;4;5;6;7;8;9] ALLSEP.
(*  set (ent_len := new_ent_len (Zlength V0)) in *.*)

  forward_if
  (PROP ( )
   LOCAL (temp _md_size (Vint (Int.repr 32)); temp _ctx (Vptr b i); temp _md_info info;
   temp _len (Vint (Int.repr (Zlength Data))); temp _custom data; gvar sha._K256 kv;
   temp _t'4 (Vint (Int.repr 32)))
   SEP (FRZL ALLSEP)).
  { elim H; trivial. }
  { clear H.
    forward_if.
    { elim H; trivial. }
    { clear H. forward. forward. entailer!. }
  }
  forward. simpl. drop_LOCAL 7%nat. (*_t'4*)

  (*NEXT INSTRUCTION:  ctx->entropy_len = entropy_len * 3 / 2*)
  thaw ALLSEP. thaw FIELDS2. forward.

  assert (FOURTYEIGHT: Int.unsigned (Int.mul (Int.repr 32) (Int.repr 3)) / 2 = 48).
  { rewrite mul_repr. simpl.
    rewrite Int.unsigned_repr. reflexivity. rewrite int_max_unsigned_eq; omega. }

  set (myABS := HMAC256DRBGabs VV (list_repeat 32 1) rc 48 pr 10000) in *.
  assert (myST: exists ST:hmac256drbgstate, ST =
    ((info, (M2, p)), (map Vint (list_repeat 32 Int.one), (Vint (Int.repr rc),
        (Vint (Int.repr 48), (Val.of_bool pr, Vint (Int.repr 10000))))))). eexists; reflexivity.
  destruct myST as [ST HST].

  freeze [0;1;2;3;4] FR_CTX.
  freeze [3;4;6;7;8] KVStreamInfoDataFreeBlk.

  (*NEXT INSTRUCTION: mbedtls_hmac_drbg_reseed( ctx, custom, len ) *)
  freeze [1;2;3] INI.
  specialize (Forall_list_repeat isbyteZ 32 1); intros IB1.
  replace_SEP 0 (
         data_at Tsh t_struct_hmac256drbg_context_st ST (Vptr b i) *
         hmac256drbg_relate myABS ST).
  { go_lower. thaw INI. clear KVStreamInfoDataFreeBlk. thaw FR_CTX.
    unfold_data_at 2%nat.
    subst ST; simpl. cancel. normalize.
    apply andp_right. apply prop_right. repeat split; trivial. apply IB1. split; omega.
    unfold md_full. simpl.
    rewrite field_at_data_at. simpl.
    unfold field_address. rewrite if_true; simpl; trivial. cancel.
    apply UNDER_SPEC.REP_FULL.
  }

  clear INI.
  thaw KVStreamInfoDataFreeBlk. freeze [3;7] OLD_MD.
  forward_call (Data, data, Zlength Data, Vptr b i, ST, myABS, kv, Info, s).
  { unfold hmac256drbgstate_md_info_pointer.
    subst ST; simpl. cancel.
  }
  { subst myABS; simpl. rewrite <- initialize.max_unsigned_modulus in *.
    split. rep_omega. (* rewrite int_max_unsigned_eq; omega.*)
    split. reflexivity.
    split. reflexivity.
    split. omega.
    split. (*change Int.modulus with 4294967296.*) rep_omega.
    split. (* change Int.modulus with 4294967296.*)
       unfold contents_with_add. if_tac. rep_omega. rewrite Zlength_nil; rep_omega.
    split. apply IB1. split; omega.
    assumption.
  }

  Intros v.

  forward.
  forward_if (
   PROP ( v = nullval)
   LOCAL (temp _ret v; temp _t'7 v;
   temp _entropy_len (Vint (Int.repr 32));
   temp _md_size (Vint (Int.repr 32)); temp _ctx (Vptr b i);
   temp _md_info info;
   temp _len (Vint (Int.repr (Zlength Data)));
   temp _custom data; gvar sha._K256 kv)
   SEP (reseedPOST v Data data (Zlength Data) s
          myABS (Vptr b i) Info kv ST; FRZL OLD_MD)).
  { rename H into Hv. forward. simpl. Exists v.
    apply andp_right. apply prop_right; split; trivial.
    unfold reseedPOST.

    remember ((zlt 256 (Zlength Data) || zlt 384 (hmac256drbgabs_entropy_len myABS + Zlength Data)) %bool) as d.
    unfold myABS in Heqd; simpl in Heqd.
    destruct (zlt 256 (Zlength Data)); simpl in Heqd.
    + subst d. unfold hmac256drbgstate_md_info_pointer, hmac256drbg_relate; simpl.
      simpl. subst myABS. normalize. simpl. cancel.
      Exists p. thaw OLD_MD. normalize.
      apply andp_right. apply prop_right; repeat split; trivial. cancel.
    + destruct (zlt 384 (48 + Zlength Data)); simpl in Heqd; try omega.
      subst d.
      unfold hmac256drbgstate_md_info_pointer, hmac256drbg_relate; simpl. normalize.
      rename H into RV.
      remember (mbedtls_HMAC256_DRBG_reseed_function s myABS
         (contents_with_add data (Zlength Data) Data)) as MRS.
      rewrite (ReseedRes _ _ _ RV). cancel.
      unfold return_value_relate_result in RV.
      destruct MRS.
      - exfalso. inv RV. simpl in Hv. discriminate.
      - unfold hmac256drbgabs_common_mpreds, hmac256drbgstate_md_info_pointer; simpl. normalize.
        Exists p. thaw OLD_MD. cancel. normalize.
        apply andp_right. apply prop_right; repeat split; trivial.
        cancel.
  }
  { rename H into Hv. forward.
    go_lower. simpl in Hv. apply typed_false_of_bool in Hv. apply negb_false_iff in Hv.
    symmetry in Hv; apply binop_lemmas2.int_eq_true in Hv. subst v.
    entailer!.
  }
  deadvars!. Intros. subst v.
  unfold reseedPOST.
  remember ((zlt 256 (Zlength Data)
          || zlt 384 (hmac256drbgabs_entropy_len myABS + Zlength Data))%bool) as d.
  destruct d; Intros.
  remember (mbedtls_HMAC256_DRBG_reseed_function s myABS
         (contents_with_add data (Zlength Data) Data)) as MRS.
  unfold return_value_relate_result in H.
  destruct MRS. Focus 2. exfalso. destruct e. inv H.
                     destruct ENT_GenErrAx as [EL1 _]. rewrite <- H in EL1. elim EL1; trivial.
  clear H. unfold hmac256drbgabs_reseed. rewrite <- HeqMRS. subst myABS; simpl.
  destruct d as [[[[newV newK] newRC] dd] newPR].
  unfold hmac256drbgabs_common_mpreds. simpl. subst ST. unfold hmac256drbgstate_md_info_pointer. simpl. Intros.
  unfold_data_at 1%nat. freeze [0;1;2;4;5;6;7;8;9;10;11] XX.
  forward. forward.
  Exists Int.zero. simpl. symmetry in Heqd. apply orb_false_iff in Heqd. destruct Heqd as [Heqd1 Heqd2].
  destruct (zlt 256 (Zlength Data)); try discriminate.
  apply andp_right. apply prop_right; split; trivial.
  thaw XX. thaw OLD_MD. cancel. simpl in *. rewrite Heqd2, <- HeqMRS.
  Exists p. normalize.
  apply andp_right. apply prop_right; repeat split; trivial.
  unfold_data_at 3%nat. cancel.
Time Qed. (*Coq8.6: 40secs*)
          (*Jan 22nd 2017: 267.171 secs (182.812u,0.015s) (successful)*)
          (*earlier: Finished transaction in 121.296 secs (70.921u,0.062s) (successful)*)


From Goose.github_com.tchajed.goose.internal.examples Require Import append_log.
From Perennial.goose_lang.lib Require Import encoding crash_lock.
From Perennial.program_proof Require Import disk_prelude.
From Perennial.program_proof Require Import disk_lib.
From Perennial.program_proof Require Import append_log_hocap.
From Perennial.program_proof Require Import append_log_refinement_triples.
From Perennial.goose_lang.ffi Require Import append_log_ffi.
From Perennial.goose_lang Require Import logical_reln_defns logical_reln_adeq spec_assert.
From Perennial.base_logic Require Import ghost_var.

Existing Instances log_spec_ext log_spec_ffi_model log_spec_ext_semantics log_spec_ffi_interp log_spec_interp_adequacy.

Section refinement.
Context `{!heapGS Σ}.
Context `{!refinement_heapG Σ}.
Context `{stagedG Σ}.

Existing Instance logG0.
Context `{Hin: inG Σ (authR (optionUR (exclR log_stateO)))}.
Context `{Hin_nat_ctx: inG Σ (authR (optionUR (exclR (leibnizO (nat * (spec_lang.(language.expr) →
                                                                       spec_lang.(language.expr)))))))}.
Context (SIZE: nat).
Context (SIZE_nonzero: 0 < SIZE).
Context (SIZE_bounds: int.nat SIZE = SIZE).

Existing Instances spec_ffi_model_field spec_ffi_op_field spec_ext_semantics_field (* spec_ffi_interp_field  *) spec_ffi_interp_adequacy_field.

Notation sstate := (@state (@spec_ffi_op_field log_spec_ext) (spec_ffi_model_field)).
Notation sexpr := (@expr (@spec_ffi_op_field log_spec_ext)).
Notation sval := (@val (@spec_ffi_op_field log_spec_ext)).

Class appendG (Σ: gFunctors) :=
  { append_stagedG :> stagedG Σ;
    append_stateG :> inG Σ (authR (optionUR (exclR log_stateO)));
    append_nat_ctx :> inG Σ (authR (optionUR (exclR (leibnizO (nat * (spec_lang.(language.expr) →
                                                                       spec_lang.(language.expr)))))))
  }.

Definition append_names := unit.
Definition append_get_names (Σ: gFunctors) (hG: appendG Σ) := tt.
Definition append_update (Σ: gFunctors) (hG: appendG Σ) (n: append_names) := hG.

Definition LVL_INIT : nat := 100.
Definition LVL_INV : nat := 75.
Definition LVL_OPS : nat := 50.
Existing Instance logG0.

Definition append_inv {Σ: gFunctors} {hG: heapGS Σ} {rG: refinement_heapG Σ} {cG: crashGS Σ} {aG : appendG Σ} :=
  (∃ γ, log_inv SIZE γ LVL_INV%nat)%I.
Definition append_init {Σ: gFunctors} {hG: heapGS Σ} {rG: refinement_heapG Σ} {cG: crashGS Σ} {aG : appendG Σ}
  : iProp Σ := (∃ γ, log_init (P γ) SIZE).
Definition append_crash_cond {Σ: gFunctors} {hG: heapGS Σ} {rG: refinement_heapG Σ} {cG: crashGS Σ} {aG : appendG Σ}
  : iProp Σ := (∃ γ, log_crash_cond (P γ) SIZE).
Definition appendN : coPset := (∅ : coPset).
Definition append_val_interp {Σ: gFunctors} {hG: heapGS Σ} {rG: refinement_heapG Σ} {cG: crashGS Σ} {aG : appendG Σ}
           (ty: @ext_tys (@val_tys _ log_ty)) : val_semTy :=
  λ vspec vimpl, (∃ (lspec: loc) (limpl: loc) γ,
            ⌜ vspec = #lspec ∧ vimpl = #limpl ⌝ ∗ is_log SIZE γ LVL_INV limpl ∗ log_open lspec)%I.

Instance appendTy_model : specTy_model log_ty.
Proof using SIZE.
 refine
  {| styG := appendG;
     sty_names := append_names;
     sty_get_names := append_get_names;
     sty_update := append_update;
     sty_inv := @append_inv;
     sty_init := @append_init;
     sty_crash_cond := @append_crash_cond;
     styN := appendN;
     sty_lvl_init := LVL (LVL_INIT);
     sty_lvl_ops := LVL (LVL_OPS);
     sty_val_interp := @append_val_interp |}.
 - intros ? [] [] => //=.
 - intros ? [] => //=.
 - intros ?? [] [] => //=.
 - rewrite /sN/appendN. apply disjoint_empty_r.
 - abstract (intros; iIntros "H"; iDestruct "H" as (??? (->&->)) "H" => //=).
Defined.
(* XXX: some of the fields should be opaque/abstract here, because they're enormous proof terms.
  perhaps specTy_model should be split into two typeclasses? *)

Existing Instances subG_stagedG.

Definition appendΣ := #[stagedΣ;
                          GFunctor (authR (optionUR (exclR log_stateO)));
                          GFunctor ((authR (optionUR (exclR (leibnizO (nat * (spec_lang.(language.expr) →
                                                                       spec_lang.(language.expr))))))))].

Instance subG_appendG: ∀ Σ, subG appendΣ Σ → appendG Σ.
Proof. solve_inG. Qed.
Definition append_initP (σimpl: @state disk_op disk_model) (σspec : @state log_op log_model) : Prop :=
  (null_non_alloc σspec.(heap)) ∧
  (σimpl.(world) = init_disk ∅ SIZE) ∧
  (σspec.(world) = UnInit).
Definition append_update_pre (Σ: gFunctors) (hG: appendG Σ) (n: append_names) : appendG Σ := hG.

Program Instance appendTy_update_model : specTy_update appendTy_model :=
  {| sty_preG := appendG;
            styΣ := appendΣ;
            subG_styPreG := subG_appendG;
            sty_update_pre := @append_update_pre |}.
Next Obligation. rewrite //=. Qed.
Next Obligation. rewrite //=. intros ?? [] => //=. Qed.

Notation append_nat_K :=
(leibnizO (nat * ((@spec_lang log_spec_ext log_spec_ffi_model log_spec_ext_semantics).(language.expr)
                           → (@spec_lang log_spec_ext log_spec_ffi_model log_spec_ext_semantics).(language.expr)))).

Lemma append_init_obligation1: sty_init_obligation1 appendTy_update_model append_initP.
Proof.
  rewrite /sty_init_obligation1//=.
  iIntros (? hG hRG hC hAppend σs σi Hinit) "Hdisk".
  rewrite /log_start /append_init/log_init.
  inversion Hinit as [Hnn [Heqi Heqs]]. rewrite Heqs Heqi.
  iIntros "(Huninit_frag&Hlog_frag)". rewrite /P//=.
  rewrite /thread_tok_full.
  iMod (ghost_var_alloc ((O, id) : append_nat_K)) as (γ) "Hown".
  iModIntro. iExists tt, γ. iLeft. iFrame.
  rewrite /append_log_proof.uninit_log.
  iExists _.
  iSplitL "Hdisk".
  - by iApply disk_array_init_disk.
  - rewrite replicate_length //=.
Qed.

Lemma append_init_obligation2: sty_init_obligation2 append_initP.
Proof. intros ?? (?&?&?). rewrite //=. Qed.

Definition append_op_trans (op: log_spec_ext.(@spec_ffi_op_field).(@external)) : @val disk_op :=
  match op with
  | AppendOp => Log__Append
  | GetOp => Log__Get
  | ResetOp => Log__Reset
  | InitOp => (λ:<>, Init #SIZE)%V
  | OpenOp => Open
  end.

Inductive append_trans : @val log_op -> @val disk_op -> Prop :=
| AppendTrans (x: string) op:
    append_trans (λ: x, ExternalOp op (Var x)) (append_op_trans op).

Lemma append_rules_obligation:
  @sty_rules_obligation _ _ disk_semantics _ _ _ _ _ _ appendTy_model append_trans.
Proof.
  intros vs0 vs v0 v0' t1 t2 Htype0 Htrans.
  inversion Htype0 as [op Heq Htype]; subst.
  destruct op; inversion Htype; inversion Htrans; subst.
  - admit.
  - admit.
  - iIntros (?????) "#Hinv #Hspec #Hval".
    iIntros (j K Hctx).
    rewrite //=.
    iIntros "Hj".
    rewrite /append_val_interp. iDestruct "Hval" as (lspec limpl γ Heq) "(His_log&Hlog_open)".
    destruct Heq as (->&->). iDestruct "Hinv" as (?) "Hinv".
    iMod (ghost_step_lifting_puredet with "[Hj]") as "(Hj&_)"; swap 1 3.
    { iFrame. iDestruct "Hspec" as "($&?)".
    }
    { set_solver+. }
    { intros ?. eexists. simpl.
      apply head_prim_step. econstructor; eauto. }
    rewrite /LVL_OPS.
    wpc_apply (@wpc_Log__Reset with "[$] []").
    { eauto. }
    { rewrite /LVL_INV. lia. }
    iSplit; first done. iNext. iIntros. iExists _. eauto.
  - inversion Htype; subst.
    iIntros (?????) "#Hinv #Hspec #Hval".
    iIntros (j K Hctx).
    rewrite //=.
    iIntros "Hj".
    rewrite /append_val_interp.
    iDestruct "Hval" as %[-> ->]. iDestruct "Hinv" as (?) "Hinv".
    wpc_pures; first done.
    iMod (ghost_step_lifting_puredet with "[Hj]") as "(Hj&_)"; swap 1 3.
    { iFrame. iDestruct "Hspec" as "($&?)".
    }
    { set_solver+. }
    { intros ?. eexists. simpl.
      apply head_prim_step. econstructor; eauto. }
    wpc_apply (@wpc_Init with "[$] []").
    { eauto. }
    { eauto. }
    { rewrite /LVL_INV. lia. }
    iSplit; first done. iNext. iIntros (?) "(#His_log&Hj)".
    iDestruct "Hj" as (?) "(Hj&Hopen)".
    iExists _. iFrame.
    iExists _, _, _, _. iSplit.
    { iPureIntro; split; eauto. }
    iSplitR ""; eauto.
    iExists _, _, _. eauto.
  - inversion Htype; subst.
    iIntros (?????) "#Hinv #Hspec #Hval".
    iIntros (j K Hctx).
    rewrite //=.
    iIntros "Hj".
    rewrite /append_val_interp.
    iDestruct "Hval" as %[-> ->]. iDestruct "Hinv" as (?) "Hinv".
    iMod (ghost_step_lifting_puredet with "[Hj]") as "(Hj&_)"; swap 1 3.
    { iFrame. iDestruct "Hspec" as "($&?)".
    }
    { set_solver+. }
    { intros ?. eexists. simpl.
      apply head_prim_step. econstructor; eauto. }
    wpc_apply (@wpc_Open with "[$] []").
    { eauto. }
    { rewrite /LVL_INV. lia. }
    iSplit; first done. iNext. iIntros (?) "(#His_log&Hj)".
    iDestruct "Hj" as (?) "(Hj&Hopen)".
    iExists _. iFrame.
    iExists _, _, _. iSplit.
    { iPureIntro; split; eauto. }
    iFrame. iFrame "#".
Admitted.

Lemma append_crash_inv_obligation:
  @sty_crash_inv_obligation _ _ disk_semantics _ _ _ _ _ _ appendTy_model.
Proof using SIZE.
  clear SIZE_bounds SIZE_nonzero.
  rewrite /sty_crash_inv_obligation//=.
  iIntros (? hG hC hRG hAppend e Φ) "Hinit Hspec Hwand".
  rewrite /append_inv/append_init/log_inv.
  iDestruct ("Hinit") as (γ) "Hinit".
  rewrite /append_crash_cond.
  iPoseProof (append_log_na_crash_inv_obligation Nlog _ POpened (PStartedOpening _)
                                                 _ _ _ _ _ _ LVL_INIT
                                                 LVL_INV LVL_OPS with "Hinit [Hwand]") as ">(Hinv&Hwp)".
  { rewrite /LVL_INIT/LVL_INV. lia. }
  { rewrite /LVL_INIT/LVL_OPS. lia. }
  { iIntros "Hinv". iApply "Hwand". iExists _. eauto. }
  iModIntro. iSplitL "Hinv".
  { iExists _. iApply "Hinv". }
  iApply (wpc_mono with "Hwp"); eauto.
  iIntros "(_&H)". iExists _. iFrame.
Qed.

Lemma append_crash_obligation:
  @sty_crash_obligation _ _ disk_semantics _ _ _ _ _ _ appendTy_model.
Proof using SIZE.
  clear SIZE_bounds.
  rewrite /sty_crash_obligation//=.
  iIntros (? hG hC hRG hAppend) "Hinv Hcrash_cond".
  iMod (ghost_var_alloc ((O, id) : append_nat_K)) as (γtok) "Hown".
  iDestruct "Hinv" as (γ1) "#Hlog_inv".
  rewrite /append_crash_cond.
  iDestruct "Hcrash_cond" as (γ2 ls) "(Hstate_to_crash&HP)".
  rewrite/ log_state_to_crash.
  iModIntro. iNext. iIntros (hG').
  iModIntro. iIntros (hC' σs Hrel).
  destruct Hrel as (?&?&_&Heq&_).
  iIntros "Hctx".
  rewrite /append_init/log_init.
  destruct (σs.(world)) eqn:Hworld_case; try iDestruct "Hctx" as %[].
  - iAssert (⌜ ls = UnInit ∨ ls = Initing ⌝ ∗ log_ctx UnInit ∗ log_frag [])%I with "[HP Hctx]" as (Heqls) "(Hctx&Hfrag)".
    {
      rewrite /log_ctx/P.
      iDestruct "Hctx" as "(?&?)".
      destruct ls; try (iDestruct "HP" as "(?&?&?)" || iDestruct "HP" as "(?&?)");
        try (iFrame; eauto; done).
      - iDestruct (log_uninit_auth_closed_frag with "[$] [$]") as %[].
      - iDestruct (log_uninit_auth_closed_frag with "[$] [$]") as %[].
      - iDestruct "HP" as (?) "(HP&?)".
        iDestruct (log_uninit_auth_opened with "[$] [$]") as %[].
    }
    iExists _. unshelve (iExists _).
    { econstructor.
      { symmetry; eauto. }
      repeat econstructor.
    }
    iFrame. iIntros (hRG' (Heq1&Heq2)) "Hrestart".
    iModIntro.
    iExists tt, γtok. iLeft.
    rewrite /logG0//=/log_frag//=. rewrite Heq2. rewrite Heq1.
    iFrame. subst.
    rewrite /append_log_proof.uninit_log.
    rewrite /disk_array. rewrite /diskG0.
    rewrite Heq.
    destruct Heqls as [-> | ->]; iFrame.
  - rewrite /P/log_ctx.
    iAssert (⌜ ls = Closed s ∨ ls = Opening s  ⌝ ∗
             log_ctx (Closed s) ∗ log_frag s)%I with "[HP Hctx]" as (Heqls) "(Hctx&Hfrag)".
    {
      rewrite /log_ctx/P.
      iDestruct "Hctx" as "(?&?)".
      destruct ls; try (iDestruct "HP" as "(?&?&?)" || iDestruct "HP" as "(?&?)");
        try (iFrame; eauto; done).
      - iDestruct (log_closed_auth_uninit_frag with "[$] [$]") as %[].
      - iDestruct (log_closed_auth_uninit_frag with "[$] [$]") as %[].
      - iDestruct (log_auth_frag_unif with "[$] [$]") as %->. iFrame. eauto.
      - iDestruct (log_auth_frag_unif with "[$] [$]") as %->. iFrame. eauto.
      - iDestruct "HP" as (?) "(HP&?)".
        iDestruct (log_closed_auth_opened with "[$] [$]") as %[].
    }
    iExists _. unshelve (iExists _).
    { econstructor.
      { symmetry; eauto. }
      simpl.
      repeat econstructor.
    }
    iFrame. iIntros (hRG' (Heq1&Heq2)) "Hrestart".
    iModIntro.
    iExists tt, γtok. iRight.
    rewrite /logG0//=/log_frag//=. rewrite Heq2. rewrite Heq1.
    iFrame. subst.
    rewrite /append_log_proof.uninit_log.
    rewrite /disk_array. rewrite /diskG0.
    destruct Heqls as [-> | ->];
      iExists _; iFrame;
      iFrame; subst;
      (* XXX: need a typeclass? or lemma? to say that these kinds of
         disk assertions are "stable" when we go from hG to hG' because
         disk ffi generation number doesn't change *)
      rewrite /append_log_proof.uninit_log;
      rewrite /append_log_proof.crashed_log;
      rewrite /append_log_proof.is_log';
      rewrite /append_log_proof.is_hdr;
      rewrite /disk_array; rewrite /diskG0;
      rewrite Heq;
      iFrame.
  - rewrite /P/log_ctx.
    iAssert (∃ l0, ⌜ ls = Opened s l0  ⌝ ∗ log_ctx (Opened s l) ∗ log_frag s)%I with "[HP Hctx]" as (? Heqls) "(Hctx&Hfrag)".
    {
      rewrite /log_ctx/P.
      iDestruct "Hctx" as "(?&?)".
      destruct ls; try (iDestruct "HP" as "(?&?&?)" || iDestruct "HP" as "(?&?)");
        try (iFrame; eauto; done).
      - iDestruct (log_uninit_auth_opened with "[$] [$]") as %[].
      - iDestruct (log_uninit_auth_opened with "[$] [$]") as %[].
      - iDestruct (log_closed_auth_opened with "[$] [$]") as %[].
      - iDestruct (log_closed_auth_opened with "[$] [$]") as %[].
      - iDestruct "HP" as (?) "(HP&?)".
        iDestruct (log_auth_frag_unif with "[$] [$]") as %->.
        iDestruct (log_open_unif with "[$] [$]") as %->. iFrame.
        iExists _. iFrame; eauto.
    }
    iExists _. unshelve (iExists _).
    { econstructor.
      { symmetry; eauto. }
      simpl.
      repeat econstructor.
    }
    iFrame. iIntros (hRG' (Heq1&Heq2)) "Hrestart".
    iModIntro.
    iExists tt, γtok. iRight.
    rewrite /logG0//=/log_frag//=. rewrite Heq2. rewrite Heq1.
    iFrame. subst.
    rewrite /append_log_proof.uninit_log.
    rewrite /disk_array. rewrite /diskG0.
      iExists _; iFrame;
      iFrame; subst;
      (* XXX: need a typeclass? or lemma? to say that these kinds of
         disk assertions are "stable" when we go from hG to hG' because
         disk ffi generation number doesn't change *)
      rewrite /append_log_proof.uninit_log;
      rewrite /append_log_proof.crashed_log;
      rewrite /append_log_proof.is_log';
      rewrite /append_log_proof.is_hdr;
      rewrite /disk_array; rewrite /diskG0;
      rewrite Heq;
      iFrame.
Qed.

Existing Instances log_semantics.
Existing Instances spec_ffi_model_field spec_ffi_op_field spec_ext_semantics_field spec_ffi_interp_field spec_ffi_interp_adequacy_field.
(* XXX: might need to change typed_translate / refinement to use the spec_ wrappers around type classes *)

Lemma append_refinement (es: @expr log_op) σs e σ (τ: @ty log_ty.(@val_tys log_op)):
  typed_translate.expr_transTy _ _ _ append_trans ∅ es e τ →
  σ.(trace) = σs.(trace) →
  σ.(oracle) = σs.(oracle) →
  append_initP σ σs →
  refinement.trace_refines e e σ es es σs.
Proof.
  intros. intros ?.
  efeed pose proof sty_adequacy; eauto using append_init_obligation1, append_init_obligation2,
                                 append_crash_inv_obligation, append_crash_obligation,
                                 append_rules_obligation.
Qed.

End refinement.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From extructures Require Import ord fmap.
From CoqUtils Require Import hseq word.

Require Import lib.utils common.types.
Require Import symbolic.symbolic sealing.classes.

Import Symbolic.

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

Module Sym.

Section WithClasses.

Context {mt : machine_types}
        {ops : machine_ops mt}
        {opss : machine_ops_spec ops}
        {scr : syscall_regs mt}
        {ssa : @sealing_syscall_addrs mt}.

Open Scope ord_scope.

Class sealing_key := {
  key : ordType;
  max_key;
  inc_key : key -> key;
  ltb_inc : forall sk, sk < max_key -> sk < inc_key sk
}.

Context {sk : sealing_key}.

(* We represent keys as tags on dummy values instead of payloads
  because this eliminates conversions from keys to words and back. *)
Inductive stag :=
| DATA   :        stag
| KEY    : key -> stag
| SEALED : key -> stag.

Definition stag_eq t1 t2 :=
  match t1, t2 with
    | DATA, DATA => true
    | KEY k1, KEY k2
    | SEALED k1, SEALED k2 => k1 == k2
    | _, _ => false
  end.

Lemma stag_eqP : Equality.axiom stag_eq.
Proof.
by move=> [|k1|k1] [|k2|k2] /=; apply: (iffP idP) => // [/eqP->|[->]].
Qed.

Definition stag_eqMixin := EqMixin stag_eqP.
Canonical stag_eqType := Eval hnf in EqType stag stag_eqMixin.

Definition stags := {|
  pc_tag_type := [eqType of unit];
  reg_tag_type := [eqType of stag];
  mem_tag_type := [eqType of stag];
  entry_tag_type := [eqType of unit]
|}.

Section WithHSeqs.

Definition sealing_handler (iv : ivec stags) : option (vovec stags (op iv)) :=
  match iv with
  | IVec (OP NOP)       tt DATA [hseq]               => Some (@OVec stags NOP tt tt)
  | IVec (OP CONST)     tt DATA [hseq _]             => Some (@OVec stags CONST tt DATA)
  | IVec (OP MOV)       tt DATA [hseq tsrc; _]       => Some (@OVec stags MOV tt tsrc)
  | IVec (OP (BINOP o)) tt DATA [hseq DATA; DATA; _] => Some (@OVec stags (BINOP o) tt DATA)
  | IVec (OP LOAD)      tt DATA [hseq DATA; tmem; _] => Some (@OVec stags LOAD tt tmem)
  | IVec (OP STORE)     tt DATA [hseq DATA; tsrc; _] => Some (@OVec stags STORE tt tsrc)
  | IVec (OP JUMP)      tt DATA [hseq DATA]          => Some (@OVec stags JUMP tt tt)
  | IVec (OP BNZ)       tt DATA [hseq DATA]          => Some (@OVec stags BNZ tt tt)
  | IVec (OP JAL)       tt DATA [hseq DATA; _]       => Some (@OVec stags JAL tt DATA)
  | IVec SERVICE        tt _    [hseq]               => Some tt
  | IVec _              tt _ _                       => None
  end.

End WithHSeqs.

Program Instance sym_sealing : params := {
  ttypes := stags;

  transfer := sealing_handler;

  internal_state := key  (* next key to generate *)
}.

Import DoNotation.

Definition mkkey (s : state mt) : option (state mt) :=
  let 'State mem reg pc@pct key := s in
  if key < max_key then
    let key' := inc_key key in
    do! reg' <- updm reg syscall_ret 0%w@(KEY key);
    do! ret  <- reg ra;
    match ret with
    | pc'@DATA => Some (State mem reg' (pc'@tt) key')
    | _ => None
    end
  else
    None.

Definition seal (s : state mt) : option (state mt) :=
  let 'State mem reg pc@pct next_key := s in
  match reg syscall_arg1, reg syscall_arg2 with
  | Some payload@DATA, Some _@(KEY key) =>
    do! reg' <- updm reg syscall_ret payload@(SEALED key);
    do! ret  <- reg ra;
    match ret with
    | pc'@DATA => Some (State mem reg' (pc'@tt) next_key)
    | _ => None
    end
  | _, _ => None
  end.

Definition unseal (s : state mt) : option (state mt) :=
  let 'State mem reg pc@pct next_key := s in
  match reg syscall_arg1, reg syscall_arg2 with
  | Some payload@(SEALED key), Some _@(KEY key') =>
    if key == key' then
      do! reg' <- updm reg syscall_ret payload@DATA;
      do! ret  <- reg ra;
      match ret with
      | pc'@DATA => Some (State mem reg' (pc'@tt) next_key)
      | _ => None
      end
    else None
  | _, _ => None
  end.

Definition sealing_syscalls : syscall_table mt :=
  [fmap (mkkey_addr,  Syscall tt mkkey);
        (seal_addr,   Syscall tt seal);
        (unseal_addr, Syscall tt unseal)].

Definition step := step sealing_syscalls.

End WithClasses.

(* BCP: Aren't there also some proof obligations that we need to satisfy? *)
(* CH: You mean for the concrete-symbolic refinement?
   I expect those to appear when talking about that refinement,
   which we don't yet *)

(* BCP: Yes, that's what I meant.  I know we're not there yet, but I
   am wondering where we want to write them.  Still confused about the
   modularization strategy for the whole codebase... *)
(* CH: We will probably make a refinementCS.v file at some point,
   and I expect that to use any of Arthur's results we'll need
   to give this kind of details *)

Notation memory mt := (Symbolic.memory mt sym_sealing).
Notation registers mt := (Symbolic.registers mt sym_sealing).

End Sym.


Require Import String List.
Import ListNotations.

Require Import Kami.Kami.
Require Import Hemiola.Lib.Index.
Require Import Compiler.HemiolaDeep Compiler.CompileK.
Require Import MesiDeep.

Set Implicit Arguments.

Definition KMesi: Kind := Bit 3.
Definition mesiM {var}: Expr var (SyntaxKind KMesi) := ($4)%kami_expr.
Definition mesiE {var}: Expr var (SyntaxKind KMesi) := ($3)%kami_expr.
Definition mesiS {var}: Expr var (SyntaxKind KMesi) := ($2)%kami_expr.
Definition mesiI {var}: Expr var (SyntaxKind KMesi) := ($1)%kami_expr.
Definition mesiNP {var}: Expr var (SyntaxKind KMesi) := ($0)%kami_expr.

Section Directory.
  Context `{ReifyConfig} `{TopoConfig}.

  Definition KDir :=
    STRUCT { "dir_st" :: KMesi;
             "dir_excl" :: KCIdx;
             "dir_sharers" :: KCBv }.

  Definition compile_dir_get {var}
             (oidx: KCIdx @ var) (dir: (Struct KDir) @ var): Expr var (SyntaxKind KMesi) :=
    (let dir_st := dir!KDir@."dir_st" in
     let dir_excl := dir!KDir@."dir_excl" in
     let dir_sharers := dir!KDir@."dir_sharers" in
     IF (dir_st == mesiM && dir_excl == oidx) then mesiM
     else IF (dir_st == mesiE && dir_excl == oidx) then mesiE
     else IF (dir_st == mesiS && bvTest dir_sharers oidx) then mesiS
     else mesiI)%kami_expr.

End Directory.

Section Instances.
  Context `{TopoConfig}.

  Instance MesiCompExtType: CompExtType :=
    {| kind_of_hetype := fun het => match het with
                                    | HDir => Struct KDir
                                    end
    |}.

  Arguments compile_bexp {_ _ _ _ _ _ _ _ _} _ _ _ _ {_}.
  Fixpoint compile_dir_exp
           (var: Kind -> Type) {het}
           (msgIn: var (Struct KMsg))
           (mshr: var (Struct MSHR))
           (frs : var (Struct KMsg))
           (ostvars: HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty))
           (he: heexp (hvar_of var) het): Expr var (SyntaxKind (kind_of het)) :=
    (match he in (hexp_dir _ h) return (Expr var (SyntaxKind (kind_of h))) with
     | HDirC _ => #(HVector.hvec_ith ostvars Mesi.dir)
     | HDirGetSt dir => ((compile_dir_exp msgIn mshr frs ostvars dir)!KDir@."dir_st")
     | HDirGetExcl dir => ((compile_dir_exp msgIn mshr frs ostvars dir)!KDir@."dir_excl")
     | HDirGetStO oidx dir => compile_dir_get (compile_bexp msgIn mshr frs ostvars oidx)
                                              (compile_dir_exp msgIn mshr frs ostvars dir)
     | HDirGetSh dir => ((compile_dir_exp msgIn mshr frs ostvars dir)!KDir@."dir_sharers")
     | HDirRemoveSh sh cidx =>
       bvUnset (compile_dir_exp msgIn mshr frs ostvars sh) (compile_bexp msgIn mshr frs ostvars cidx)
     | HDirAddSharer oidx dir =>
       (let kdir := compile_dir_exp msgIn mshr frs ostvars dir in
        STRUCT { "dir_st" ::= mesiS;
                 "dir_excl" ::= kdir!KDir@."dir_excl";
                 "dir_sharers" ::=
                   IF (kdir!KDir@."dir_st" == mesiS)
                 then (bvSet (kdir!KDir@."dir_sharers") (compile_bexp msgIn mshr frs ostvars oidx))
                 else (bvSingleton _ (compile_bexp msgIn mshr frs ostvars oidx)) })
     | HDirRemoveSharer oidx dir =>
       (let kdir := compile_dir_exp msgIn mshr frs ostvars dir in
        STRUCT { "dir_st" ::= mesiS;
                 "dir_excl" ::= kdir!KDir@."dir_excl";
                 "dir_sharers" ::= bvUnset (kdir!KDir@."dir_sharers")
                                           (compile_bexp msgIn mshr frs ostvars oidx) })

     | HDirSetM oidx => (STRUCT { "dir_st" ::= mesiM;
                                  "dir_excl" ::= compile_bexp msgIn mshr frs ostvars oidx;
                                  "dir_sharers" ::= $$Default })
     | HDirSetE oidx => (STRUCT { "dir_st" ::= mesiE;
                                  "dir_excl" ::= compile_bexp msgIn mshr frs ostvars oidx;
                                  "dir_sharers" ::= $$Default })
     | HDirSetS oinds => (STRUCT { "dir_st" ::= mesiS;
                                   "dir_excl" ::= $$Default;
                                   "dir_sharers" ::=
                                     List.fold_left
                                       (fun bv i => bvSet bv i)
                                       (map (compile_bexp msgIn mshr frs ostvars) oinds)
                                       $$Default })
     | HDirSetI _ => (STRUCT { "dir_st" ::= mesiI;
                               "dir_excl" ::= $$Default;
                               "dir_sharers" ::= $$Default })

     | HRqUpFrom oidx => {$TopoTemplate.rqUpIdx, compile_dir_exp msgIn mshr frs ostvars oidx}
     | HRsUpFrom oidx => {$TopoTemplate.rsUpIdx, compile_dir_exp msgIn mshr frs ostvars oidx}
     | HDownTo oidx => {$TopoTemplate.downIdx, compile_dir_exp msgIn mshr frs ostvars oidx}
     | HRqUpFromM oinds => compile_dir_exp msgIn mshr frs ostvars oinds
     | HRsUpFromM oinds => compile_dir_exp msgIn mshr frs ostvars oinds
     | HDownToM oinds => compile_dir_exp msgIn mshr frs ostvars oinds
     | HSingleton se => bvSet $$Default (_truncate_ (compile_dir_exp msgIn mshr frs ostvars se))
     | HInvalidate se =>
       (* (IF ((compile_bexp msgIn mshr ostvars se) == mesiNP) then mesiNP else mesiI) *)
       mesiI
     end)%kami_expr.

  Definition compile_dir_OPrec
             (var: Kind -> Type)
             (msgIn: var (Struct KMsg))
             (mshr: var (Struct MSHR))
             (frs : var (Struct KMsg))
             (ostvars: HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty))
             (pd: heoprec (hvar_of var)): Expr var (SyntaxKind Bool) :=
    (match pd with
     | DirLastSharer cidx =>
       bvIsSingleton (#(HVector.hvec_ith ostvars Mesi.dir)!KDir@."dir_sharers")
                     (compile_bexp msgIn mshr frs ostvars cidx)
     | DirNotLastSharer _ =>
       bvCount (#(HVector.hvec_ith ostvars Mesi.dir)!KDir@."dir_sharers") > $1
     | DirOtherSharerExists cidx =>
       bvUnset (#(HVector.hvec_ith ostvars Mesi.dir)!KDir@."dir_sharers")
               (compile_bexp msgIn mshr frs ostvars cidx) != $0
     end)%kami_expr.

  Instance MesiCompExtExp: CompExtExp :=
    {| compile_eexp := compile_dir_exp;
       compile_eoprec := compile_dir_OPrec
    |}.

  Definition MesiInfo :=
    STRUCT { "mesi_owned" :: Bool;
             "mesi_status" :: KMesi;
             "mesi_dir_st" :: KMesi;
             "mesi_dir_sharers" :: Bit hcfg_children_max }.
  Let MesiInfoK := Struct MesiInfo.

  Variables indexSz lgWay edirLgWay: nat.

  Definition MesiInfoRead := InfoRead MesiInfoK indexSz hcfg_addr_sz lgWay edirLgWay.
  Let MesiInfoReadK := Struct MesiInfoRead.

  Definition mesi_compile_info_to_ostVars
             (var: Kind -> Type) (pinfo: var MesiInfoK)
             (cont: HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty) ->
                    ActionT var Void): ActionT var Void :=
    (LET value <- $$Default;
    LET owned <- #pinfo!MesiInfo@."mesi_owned";
    LET status: KMesi <- #pinfo!MesiInfo@."mesi_status";
    LET dir <- STRUCT { "dir_st" ::=
                          (IF (#pinfo!MesiInfo@."mesi_dir_st" == mesiNP)
                           then mesiI else #pinfo!MesiInfo@."mesi_dir_st");
                        "dir_excl" ::= bvFirstSet (#pinfo!MesiInfo@."mesi_dir_sharers");
                        "dir_sharers" ::= #pinfo!MesiInfo@."mesi_dir_sharers" };
    cont (value, (owned, (status, (dir, tt)))))%kami_action.

  Definition mesi_compile_value_read_to_ostVars
             (var: Kind -> Type)
             (ostVars: HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty))
             (rval: var KValue)
    : HVector.hvec (Vector.map (fun hty => var (kind_of hty)) hostf_ty) :=
    HVector.hvec_upd ostVars Mesi.val rval.

  Definition MesiLineWrite := LineWrite lgWay edirLgWay MesiInfoK.
  Let MesiLineWriteK := Struct MesiLineWrite.

  Definition mesi_compile_line_update
             (var: Kind -> Type) (line: var MesiLineWriteK)
             i ht (Heq: Vector.nth hostf_ty i = ht)
             (ve: Expr var (SyntaxKind (kind_of ht))): Expr var (SyntaxKind MesiLineWriteK).
  Proof.
    subst ht.
    refine (if Fin.eq_dec i Mesi.val then _
            else if Fin.eq_dec i Mesi.owned then _
                 else if Fin.eq_dec i Mesi.status then _
                      else if Fin.eq_dec i Mesi.dir then _
                           else ($$Default)%kami_expr); subst i.
    - exact (STRUCT { "addr" ::= #line!MesiLineWrite@."addr";
                      "info_write" ::= #line!MesiLineWrite@."info_write";
                      "info_hit" ::= #line!MesiLineWrite@."info_hit";
                      "info_way" ::= #line!MesiLineWrite@."info_way";
                      "edir_hit" ::= #line!MesiLineWrite@."edir_hit";
                      "edir_way" ::= #line!MesiLineWrite@."edir_way";
                      "edir_slot" ::= #line!MesiLineWrite@."edir_slot";
                      "info" ::= #line!MesiLineWrite@."info";
                      "value_write" ::= $$true;
                      "value" ::= ve;
                      "may_victim" ::= #line!MesiLineWrite@."may_victim";
                      "reps" ::= #line!MesiLineWrite@."reps" })%kami_expr.
    - exact (STRUCT { "addr" ::= #line!MesiLineWrite@."addr";
                      "info_write" ::= $$true;
                      "info_hit" ::= #line!MesiLineWrite@."info_hit";
                      "info_way" ::= #line!MesiLineWrite@."info_way";
                      "edir_hit" ::= #line!MesiLineWrite@."edir_hit";
                      "edir_way" ::= #line!MesiLineWrite@."edir_way";
                      "edir_slot" ::= #line!MesiLineWrite@."edir_slot";
                      "info" ::= updStruct (#line!MesiLineWrite@."info")%kami_expr
                                           (MesiInfo!!"mesi_owned")
                                           ve;
                      "value_write" ::= #line!MesiLineWrite@."value_write";
                      "value" ::= #line!MesiLineWrite@."value";
                      "may_victim" ::= #line!MesiLineWrite@."may_victim";
                      "reps" ::= #line!MesiLineWrite@."reps" })%kami_expr.
    - exact (STRUCT { "addr" ::= #line!MesiLineWrite@."addr";
                      "info_write" ::= $$true;
                      "info_hit" ::= #line!MesiLineWrite@."info_hit";
                      "info_way" ::= #line!MesiLineWrite@."info_way";
                      "edir_hit" ::= #line!MesiLineWrite@."edir_hit";
                      "edir_way" ::= #line!MesiLineWrite@."edir_way";
                      "edir_slot" ::= #line!MesiLineWrite@."edir_slot";
                      "info" ::= updStruct (#line!MesiLineWrite@."info")%kami_expr
                                           (MesiInfo!!"mesi_status")
                                           ve;
                      "value_write" ::= #line!MesiLineWrite@."value_write";
                      "value" ::= #line!MesiLineWrite@."value";
                      "may_victim" ::= #line!MesiLineWrite@."may_victim";
                      "reps" ::= #line!MesiLineWrite@."reps" })%kami_expr.
    - exact (STRUCT { "addr" ::= #line!MesiLineWrite@."addr";
                      "info_write" ::= $$true;
                      "info_hit" ::= #line!MesiLineWrite@."info_hit";
                      "info_way" ::= #line!MesiLineWrite@."info_way";
                      "edir_hit" ::= #line!MesiLineWrite@."edir_hit";
                      "edir_way" ::= #line!MesiLineWrite@."edir_way";
                      "edir_slot" ::= #line!MesiLineWrite@."edir_slot";
                      "info" ::=
                        STRUCT { "mesi_owned" ::= #line!MesiLineWrite@."info"!MesiInfo@."mesi_owned";
                                 "mesi_status" ::= #line!MesiLineWrite@."info"!MesiInfo@."mesi_status";
                                 "mesi_dir_st" ::= ve!KDir@."dir_st";
                                 "mesi_dir_sharers" ::=
                                   (IF (ve!KDir@."dir_st" == mesiS)
                                    then (ve!KDir@."dir_sharers")
                                    else (bvSingleton _ (ve!KDir@."dir_excl"))) };
                      "value_write" ::= #line!MesiLineWrite@."value_write";
                      "value" ::= #line!MesiLineWrite@."value";
                      "may_victim" ::= #line!MesiLineWrite@."may_victim";
                      "reps" ::= #line!MesiLineWrite@."reps" })%kami_expr.
  Defined.

  Instance MesiCompLineRW: CompLineRW lgWay edirLgWay :=
    {| infoK := MesiInfoK;
       invRsId := idx_to_word hcfg_msg_id_sz Mesi.mesiInvRs;
       compile_info_to_ostVars := mesi_compile_info_to_ostVars;
       compile_value_read_to_ostVars := mesi_compile_value_read_to_ostVars;
       compile_line_update := mesi_compile_line_update |}.

End Instances.

Require Import Hemiola.Ex.TopoTemplate.

Section Cache.
  Context `{TopoConfig}.
  Variables (oidx: IdxT)
            (indexSz lgWay edirLgWay predNumVictims: nat).

  Definition BitsPerByte := 8.
  Definition offsetSz := Nat.log2 (Nat.div hcfg_addr_sz BitsPerByte) + hcfg_line_values_lg.
  Definition tagSz := hcfg_addr_sz - indexSz - offsetSz.

  Definition getIndexE (var: Kind -> Type)
             (addr: Expr var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))))
    : Expr var (SyntaxKind (Bit indexSz)) :=
    (UniBit (ConstExtract _ _ _) addr)%kami_expr.

  Definition getIndex (var: Kind -> Type)
             (addr: fullType var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))))
    : Expr var (SyntaxKind (Bit indexSz)) :=
    getIndexE (#addr)%kami_expr.

  Definition getTag (var: Kind -> Type)
             (addr: fullType var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))))
    : Expr var (SyntaxKind (Bit tagSz)) :=
    (_truncLsb_ #addr)%kami_expr.

  Definition buildAddr (var: Kind -> Type)
             (tag: fullType var (SyntaxKind (Bit tagSz)))
             (index: fullType var (SyntaxKind (Bit indexSz)))
    : Expr var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))) :=
    {#tag, {#index, $0}}%kami_expr.

  Definition mshrConflictF (var: Kind -> Type)
             (addr1 addr2: Expr var (SyntaxKind (Bit (offsetSz + indexSz + tagSz))))
    : Expr var (SyntaxKind Bool) :=
    (addr1 != addr2 && getIndexE addr1 == getIndexE addr2)%kami_expr.

  Definition MesiEDir :=
    STRUCT { "mesi_edir_owned" :: Bool;
             "mesi_edir_st" :: KMesi;
             "mesi_edir_sharers" :: Bit hcfg_children_max }.
  Let MesiEDirK := Struct MesiEDir.

  Definition edirToInfo (var: Kind -> Type)
             (edir: fullType var (SyntaxKind MesiEDirK))
    : Expr var (SyntaxKind (Struct MesiInfo)) :=
    (STRUCT { "mesi_owned" ::= #edir!MesiEDir@."mesi_edir_owned";
              "mesi_status" ::= mesiI;
              "mesi_dir_st" ::= #edir!MesiEDir@."mesi_edir_st";
              "mesi_dir_sharers" ::= #edir!MesiEDir@."mesi_edir_status" })%kami_expr.

  Definition edirFromInfo (var: Kind -> Type)
             (pinfo: fullType var (SyntaxKind (Struct MesiInfo)))
    : Expr var (SyntaxKind MesiEDirK) :=
    (STRUCT { "mesi_edir_owned" ::= #pinfo!MesiInfo@."mesi_owned";
              "mesi_edir_st" ::= #pinfo!MesiInfo@."mesi_dir_st";
              "mesi_edir_sharers" ::= #pinfo!MesiInfo@."mesi_dir_sharers" })%kami_expr.

  Definition isJustDir (var: Kind -> Type)
             (pinfo: fullType var (SyntaxKind (Struct MesiInfo)))
    : Expr var (SyntaxKind Bool) :=
    ((#pinfo!MesiInfo@."mesi_status" <= mesiI) &&
     (#pinfo!MesiInfo@."mesi_dir_st" != mesiE))%kami_expr.

  Definition isDirInvalid (var: Kind -> Type)
             (pinfo: fullType var (SyntaxKind (Struct MesiInfo)))
    : Expr var (SyntaxKind Bool) :=
    (#pinfo!MesiInfo@."mesi_dir_st" <= mesiI)%kami_expr.

  Definition edirEmptySlot (var: Kind -> Type)
             (edir: Expr var (SyntaxKind MesiEDirK))
    : Expr var (SyntaxKind Bool) :=
    (edir!MesiEDir@."mesi_edir_st" <= mesiI)%kami_expr.

  Definition mesiInfoInit: ConstT (Struct MesiInfo) :=
    (CSTRUCT { "mesi_owned" ::= ConstBool false;
               "mesi_status" ::= ConstBit $1;
               "mesi_dir_st" ::= ConstBit $1;
               "mesi_dir_sharers" ::= ConstBit $0 })%init.

  Definition mesiEDirInit: ConstT MesiEDirK :=
    (CSTRUCT { "mesi_edir_owned" ::= ConstBool false;
               "mesi_edir_st" ::= ConstBit $1;
               "mesi_edir_sharers" ::= ConstBit $0 })%init.

  Definition mesiL1: Modules :=
    cache oidx KValue lgWay 0
          mesiInfoInit getIndex getTag buildAddr isDirInvalid predNumVictims.

  Definition mesiLi: Modules :=
    ncid oidx KValue lgWay edirLgWay
         mesiInfoInit mesiEDirInit
         getIndex getTag buildAddr edirToInfo edirFromInfo isJustDir isDirInvalid edirEmptySlot
         predNumVictims.

End Cache.