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 byte) := 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 byte): 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 byte,
        Ctx: hmac256drbgstate,
        Info: md_info_state, s:ENTROPY.stream, rc:Z, pr_flag:bool, ri:Z,
        handle_ss: DRBG_state_handle * ENTROPY.stream, gv: globals
    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 /\
             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; gvars gv)
       SEP (
         data_at Ews t_struct_hmac256drbg_context_st Ctx ctx;
         preseed_relate dp rc pr_flag ri Ctx;
         data_at Ews t_struct_mbedtls_md_info Info info;
         da_emp Ews (tarray tuchar (Zlength Data)) (map Vubyte Data) data;
         K_vector gv; Stream s; mem_mgr gv)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp (Vint ret_value))
       SEP (data_at Ews t_struct_mbedtls_md_info Info info;
            da_emp Ews (tarray tuchar (Zlength Data)) (map Vubyte Data) data;
            K_vector gv;
            if Int.eq ret_value (Int.repr (-20864))
            then data_at Ews 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,
                 match (fst Ctx, fst handle_ss) with ((M1, (M2, M3)), ((((newV, newK), newRC), newEL), newPR))
                   => let CtxFinal := ((info, (M2, p)), (map Vubyte newV, (Vint (Int.repr newRC), (Vint (Int.repr 32), (Val.of_bool newPR, Vint (Int.repr 10000)))))) in
                      !!(ret_value = Int.zero)
                      && data_at Ews t_struct_hmac256drbg_context_st CtxFinal ctx *
                         hmac256drbg_relate (HMAC256DRBGabs newK newV newRC 32 newPR 10000) CtxFinal *
                         Stream (snd handle_ss)
                end;
            mem_mgr gv).

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 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, Ews, Vint (Int.repr 1), info, gv).

  Intros v. rename H into Hv.
  forward.
  forward_if.
  { 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; auto. }
  subst v. clear Hv. simpl.
  Intros. Intros p.

  (*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 [2;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;4;5;6;8] FR2.
  forward_call (Vptr b i, Ews, ((info,(M2,p)):mdstate), 32, initial_key, b, Ptrofs.add i (Ptrofs.repr 12), Ews, gv).
  { split3; auto. split; auto.
  }

  (*call  memset( ctx->V, 0x01, md_size )*)
  freeze [0;1;3;4] FR3.
  forward_call (Ews, 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 Ews 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 (temp _t'4 (Vint (Int.repr 32))).
  { 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. rep_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;3;4;5;9] FR_CTX.
  freeze [1;7;8;9] KVStreamInfoDataFreeBlk.

  (*NEXT INSTRUCTION: mbedtls_hmac_drbg_reseed( ctx, custom, len ) *)
  freeze [1;3;4;5] INI.
  replace_SEP 0 (
         data_at Ews t_struct_hmac256drbg_context_st ST (Vptr b i) *
         hmac256drbg_relate myABS ST).
  { entailer!. thaw INI. clear - FC_V. (*KVStreamInfoDataFreeBlk.*) thaw FR_CTX.
    simpl. entailer!.
    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 [6] OLD_MD.
  forward_call (Data, data, Ews, Zlength Data, Vptr b i, Ews, ST, myABS, Info, s, gv).
  { unfold hmac256drbgstate_md_info_pointer.
    subst ST; simpl. cancel.
  }
  { subst myABS; simpl. rewrite <- initialize.max_unsigned_modulus in *.
    split3; auto. split. rep_omega. (* rewrite int_max_unsigned_eq; omega.*)
    split. reflexivity.
    split. reflexivity.
    split. omega.
    split. (*change Int.modulus with 4294967296.*) rep_omega.
     unfold contents_with_add. simple_if_tac. rep_omega. rewrite Zlength_nil; rep_omega.
  }

  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. simple_if_tac. right; trivial. left; trivial. }
  forward.
  deadvars!.
  forward_if (v = nullval).
  { 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 byte,
        Ctx: hmac256drbgstate,
        Info: md_info_state, s:ENTROPY.stream, rc:Z, pr_flag:bool, ri:Z, gv: globals
    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)
       LOCAL (temp _ctx ctx; temp _md_info info;
              temp _len (Vint (Int.repr len)); temp _custom data; gvars gv)
       SEP (
         data_at Ews t_struct_hmac256drbg_context_st Ctx ctx;
         preseed_relate dp rc pr_flag ri Ctx;
         data_at Ews t_struct_mbedtls_md_info Info info;
         da_emp Ews (tarray tuchar (Zlength Data)) (map Vubyte Data) data;
         K_vector gv; Stream s; mem_mgr gv)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp (Vint ret_value))
       SEP (data_at Ews t_struct_mbedtls_md_info Info info;
            da_emp Ews (tarray tuchar (Zlength Data)) (map Vubyte Data) data;
            K_vector gv;
            if Int.eq ret_value (Int.repr (-20864))
            then data_at Ews 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,
                 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 Ews 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 Ews 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 Vubyte 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 Ews t_struct_hmac256drbg_context_st CtxFinal ctx *
                                    hmac256drbg_relate CTXFinal CtxFinal *
                                    Stream ss end
                        end
                end;
             mem_mgr gv).

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, Ews, Vint (Int.repr 1), info, gv).

  Intros v. rename H into Hv.
  freeze [0] FR1. forward. thaw FR1.
  forward_if.
  { 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; auto. }
  subst v. clear Hv. simpl.
  Intros. Intros p.

  (*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 [2;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;4;5;6;8] FR2.
(*
  replace_SEP 1 (UNDER_SPEC.EMPTY Ews p).
  { entailer!.
    eapply derives_trans. 2: apply UNDER_SPEC.mkEmpty.
    fix_hmacdrbg_compspecs. apply derives_refl.
  }
*)
  forward_call (Vptr b i, Ews, ((info,(M2,p)):mdstate), 32, initial_key, b, Ptrofs.add i (Ptrofs.repr 12), Ews, gv).
  { split3; auto. split; auto.
  }

  (*call  memset( ctx->V, 0x01, md_size )*)
  freeze [0;1;3;4] FR3.
  forward_call (Ews, 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 Ews 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 (temp _t'4 (Vint (Int.repr 32))).
  { 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. rep_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;3;4;5;9] FR_CTX.
  freeze [1;7;8;9] KVStreamInfoDataFreeBlk.

  (*NEXT INSTRUCTION: mbedtls_hmac_drbg_reseed( ctx, custom, len ) *)
  freeze [1;3;4;5] INI.
  replace_SEP 0 (
         data_at Ews t_struct_hmac256drbg_context_st ST (Vptr b i) *
         hmac256drbg_relate myABS ST).
  { entailer!. thaw INI. clear - FC_V. (*KVStreamInfoDataFreeBlk.*) thaw FR_CTX.
    simpl; entailer!.
    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 [6] OLD_MD.
  forward_call (Data, data, Ews, Zlength Data, Vptr b i, Ews, ST, myABS, Info, s, gv).
  { unfold hmac256drbgstate_md_info_pointer.
    subst ST; simpl. cancel.
  }
  { subst myABS; simpl. rewrite <- initialize.max_unsigned_modulus in *.
    split3; auto. split. rep_omega. (* rewrite int_max_unsigned_eq; omega.*)
    split. reflexivity.
    split. reflexivity.
    split. omega.
    split. rep_omega.
    unfold contents_with_add. simple_if_tac. rep_omega. rewrite Zlength_nil; rep_omega.
  }

  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. simple_if_tac. right; trivial. left; trivial. }
  forward.
  deadvars!.
  forward_if (v = nullval).
  { 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. 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 Vubyte V = V' /\
        Zlength V = 32 /\
        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 byte,
        Ctx: hmac256drbgstate,
        (*CTX: hmac256drbgabs,*)
        Info: md_info_state, s:ENTROPY.stream, rc:Z, pr:bool, ri:Z, VV:list byte, gv: globals
    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)
       LOCAL (temp _ctx ctx; temp _md_info info;
              temp _len (Vint (Int.repr len)); temp _custom data; gvars gv)
       SEP (
         data_at Ews t_struct_hmac256drbg_context_st Ctx ctx;
         preseed_relate VV rc pr ri Ctx;
         (*hmac256drbg_relate CTX Ctx;*)
         data_at Ews t_struct_mbedtls_md_info Info info;
         da_emp Ews (tarray tuchar (Zlength Data)) (map Vubyte Data) data;
         K_vector gv; Stream s; mem_mgr gv)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp (Vint ret_value))
       SEP (data_at Ews t_struct_mbedtls_md_info Info info;
            da_emp Ews (tarray tuchar (Zlength Data)) (map Vubyte Data) data;
            K_vector gv;
            if Int.eq ret_value (Int.repr (-20864))
            then data_at Ews 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 (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 Byte.one) rc 48 pr 10000 in
                       data_at Ews t_struct_hmac256drbg_context_st CtxFinal ctx *
                                     hmac256drbg_relate CTXFinal CtxFinal))

                   else let myABS := HMAC256DRBGabs VV (list_repeat 32 Byte.one) 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 Byte.one) rc 48 pr 10000 in
                                       data_at Ews 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 Vubyte 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 Ews t_struct_hmac256drbg_context_st CtxFinal ctx *
                                    hmac256drbg_relate CTXFinal CtxFinal *
                                    Stream ss end
                        end
                end;
         mem_mgr gv).

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, Ews, Vint (Int.repr 1), info, gv).
  Intros v. rename H into Hv.
  freeze [0] FR1. forward. thaw FR1.

  forward_if.
  { 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; auto. }
  subst v. clear Hv. simpl.
  Intros p.

  (*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.
  thaw FIELDS.
  freeze [2;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;4;5;6;8] FR2.
  forward_call (Vptr b i, Ews, ((info,(M2,p)):mdstate), 32, VV, b, Ptrofs.add i (Ptrofs.repr 12), Ews, gv).
  { rewrite ZL_VV, ptrofs_add_repr_0_r; simpl.
    apply prop_right; repeat split; trivial.
  }
  { split3; auto. split; auto.
  }
  Intros.

  (*call  memset( ctx->V, 0x01, md_size )*)
  freeze [0;1;3;4] FR3.
  forward_call (Ews, 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 Ews 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;1] ALLSEP.
(*  set (ent_len := new_ent_len (Zlength V0)) in *.*)

  forward_if (temp _t'4 (Vint (Int.repr 32))).
  { elim H; trivial. }
  { clear H.
    forward_if.
    { elim H; trivial. }
    { clear H. forward. forward. entailer!. }
  }
  forward. simpl. drop_LOCAL 1%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. rep_omega. }

  set (myABS := HMAC256DRBGabs VV (list_repeat 32 Byte.one) 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;3;4;5;13] FR_CTX.
  freeze [1;7;8;9] KVStreamInfoDataFreeBlk.

  (*NEXT INSTRUCTION: mbedtls_hmac_drbg_reseed( ctx, custom, len ) *)
  freeze [1;3;4;5] INI.
  replace_SEP 0 (
         data_at Ews 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.
    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 [6] OLD_MD.
  forward_call (Data, data, Ews, Zlength Data, Vptr b i, Ews, ST, myABS, Info, s, gv).
  { unfold hmac256drbgstate_md_info_pointer.
    subst ST; simpl. cancel.
  }
  { subst myABS; simpl. rewrite <- initialize.max_unsigned_modulus in *.
    split3; auto. split. rep_omega. (* rewrite int_max_unsigned_eq; omega.*)
    split. reflexivity.
    split. reflexivity.
    split. omega.
    split. (*change Int.modulus with 4294967296.*) rep_omega.
       unfold contents_with_add. simple_if_tac. rep_omega. rewrite Zlength_nil; rep_omega.
  }

  Intros v.

  forward.
  forward_if (v = nullval).
  { 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.
        Intros. 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. 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 1%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)*)


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

(** Register allocation by external oracle and a posteriori validation. *)

Require Import FSets.
Require FSetAVLplus.
Require Archi.
Require Import Coqlib.
Require Import Ordered.
Require Import Errors.
Require Import Maps.
Require Import Lattice.
Require Import AST.
Require Import Integers.
Require Import Memdata.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import Kildall.
Require Import Locations.
Require Import Conventions.
Require Import RTLtyping.
Require Import LTL.

(** The validation algorithm used here is described in
  "Validating register allocation and spilling",
  by Silvain Rideau and Xavier Leroy,
  in Compiler Construction (CC 2010), LNCS 6011, Springer, 2010. *)

(** * Structural checks *)

(** As a first pass, we check the LTL code returned by the external oracle
  against the original RTL code for structural conformance.
  Each RTL instruction was transformed into a LTL basic block whose
  shape must agree with the RTL instruction.  For example, if the RTL
  instruction is [Istore(Mint32, addr, args, src, s)], the LTL basic block
  must be of the following shape:
- zero, one or several "move" instructions
- a store instruction [Lstore(Mint32, addr, args', src')]
- a [Lbranch s] instruction.

  The [block_shape] type below describes all possible cases of structural
  maching between an RTL instruction and an LTL basic block.
*)

Definition moves := list (loc * loc)%type.

Inductive block_shape: Type :=
  | BSnop (mv: moves) (s: node)
  | BSmove (src: reg) (dst: reg) (mv: moves) (s: node)
  | BSmakelong (src1 src2: reg) (dst: reg) (mv: moves) (s: node)
  | BSlowlong (src: reg) (dst: reg) (mv: moves) (s: node)
  | BShighlong (src: reg) (dst: reg) (mv: moves) (s: node)
  | BSop (op: operation) (args: list reg) (res: reg)
         (mv1: moves) (args': list mreg) (res': mreg)
         (mv2: moves) (s: node)
  | BSopdead (op: operation) (args: list reg) (res: reg)
         (mv: moves) (s: node)
  | BSload (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args': list mreg) (dst': mreg)
         (mv2: moves) (s: node)
  | BSloaddead (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
         (mv: moves) (s: node)
  | BSload2 (addr1 addr2: addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args1': list mreg) (dst1': mreg)
         (mv2: moves) (args2': list mreg) (dst2': mreg)
         (mv3: moves) (s: node)
  | BSload2_1 (addr: addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args': list mreg) (dst': mreg)
         (mv2: moves) (s: node)
  | BSload2_2 (addr addr': addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args': list mreg) (dst': mreg)
         (mv2: moves) (s: node)
  | BSstore (chunk: memory_chunk) (addr: addressing) (args: list reg) (src: reg)
         (mv1: moves) (args': list mreg) (src': mreg)
         (s: node)
  | BSstore2 (addr1 addr2: addressing) (args: list reg) (src: reg)
         (mv1: moves) (args1': list mreg) (src1': mreg)
         (mv2: moves) (args2': list mreg) (src2': mreg)
         (s: node)
  | BScall (sg: signature) (ros: reg + ident) (args: list reg) (res: reg)
         (mv1: moves) (ros': mreg + ident) (mv2: moves) (s: node)
  | BStailcall (sg: signature) (ros: reg + ident) (args: list reg)
         (mv1: moves) (ros': mreg + ident)
  | BSbuiltin (ef: builtin) (args: list reg) (res: reg)
         (mv1: moves) (args': list mreg) (res': list mreg)
         (mv2: moves) (s: node)
  | BSannot (text: ident) (targs: list annot_arg) (args: list reg) (res: reg)
         (mv: moves) (args': list loc) (s: node)
  | BScond (cond: condition) (args: list reg)
         (mv: moves) (args': list mreg) (s1 s2: node)
  | BSjumptable (arg: reg)
         (mv: moves) (arg': mreg) (tbl: list node)
  | BSreturn (arg: option reg)
         (mv: moves).

(** Extract the move instructions at the beginning of block [b].
  Return the list of moves and the suffix of [b] after the moves. *)

Fixpoint extract_moves (accu: moves) (b: bblock) {struct b} : moves * bblock :=
  match b with
  | Lgetstack sl ofs ty dst :: b' =>
      extract_moves ((S sl ofs ty, R dst) :: accu) b'
  | Lsetstack src sl ofs ty :: b' =>
      extract_moves ((R src, S sl ofs ty) :: accu) b'
  | Lop op args res :: b' =>
      match is_move_operation op args with
      | Some arg => extract_moves ((R arg, R res) :: accu) b'
      | None => (List.rev accu, b)
      end
  | _ =>
      (List.rev accu, b)
  end.

Definition check_succ (s: node) (b: LTL.bblock) : bool :=
  match b with
  | Lbranch s' :: _ => peq s s'
  | _ => false
  end.

Notation "'do' X <- A ; B" := (match A with Some X => B | None => None end)
         (at level 200, X ident, A at level 100, B at level 200)
         : option_monad_scope.

Notation "'assertion' A ; B" := (if A then B else None)
         (at level 200, A at level 100, B at level 200)
         : option_monad_scope.

Local Open Scope option_monad_scope.

(** Classify operations into moves, 64-bit integer operations, and other
  arithmetic/logical operations. *)

Inductive operation_kind: operation -> list reg -> Type :=
  | operation_Omove: forall arg, operation_kind Omove (arg :: nil)
  | operation_Omakelong: forall arg1 arg2, operation_kind Omakelong (arg1 :: arg2 :: nil)
  | operation_Olowlong: forall arg, operation_kind Olowlong (arg :: nil)
  | operation_Ohighlong: forall arg, operation_kind Ohighlong (arg :: nil)
  | operation_other: forall op args, operation_kind op args.

Definition classify_operation (op: operation) (args: list reg) : operation_kind op args :=
  match op, args with
  | Omove, arg::nil => operation_Omove arg
  | Omakelong, arg1::arg2::nil => operation_Omakelong arg1 arg2
  | Olowlong, arg::nil => operation_Olowlong arg
  | Ohighlong, arg::nil => operation_Ohighlong arg
  | op, args => operation_other op args
  end.

(** Check RTL instruction [i] against LTL basic block [b].
  On success, return [Some] with a [block_shape] describing the correspondence.
  On error, return [None]. *)

Definition pair_instr_block
               (i: RTL.instruction) (b: LTL.bblock) : option block_shape :=
  match i with
  | Inop s =>
      let (mv, b1) := extract_moves nil b in
      assertion (check_succ s b1); Some(BSnop mv s)
  | Iop op args res s =>
      match classify_operation op args with
      | operation_Omove arg =>
          let (mv, b1) := extract_moves nil b in
          assertion (check_succ s b1); Some(BSmove arg res mv s)
      | operation_Omakelong arg1 arg2 =>
          let (mv, b1) := extract_moves nil b in
          assertion (check_succ s b1); Some(BSmakelong arg1 arg2 res mv s)
      | operation_Olowlong arg =>
          let (mv, b1) := extract_moves nil b in
          assertion (check_succ s b1); Some(BSlowlong arg res mv s)
      | operation_Ohighlong arg =>
          let (mv, b1) := extract_moves nil b in
          assertion (check_succ s b1); Some(BShighlong arg res mv s)
      | operation_other _ _ =>
          let (mv1, b1) := extract_moves nil b in
          match b1 with
          | Lop op' args' res' :: b2 =>
              let (mv2, b3) := extract_moves nil b2 in
              assertion (eq_operation op op');
              assertion (check_succ s b3);
              Some(BSop op args res mv1 args' res' mv2 s)
          | _ =>
              assertion (check_succ s b1);
              Some(BSopdead op args res mv1 s)
          end
      end
  | Iload chunk addr args dst s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lload chunk' addr' args' dst' :: b2 =>
          if chunk_eq chunk Mint64 then
            assertion (chunk_eq chunk' Mint32);
            let (mv2, b3) := extract_moves nil b2 in
            match b3 with
            | Lload chunk'' addr'' args'' dst'' :: b4 =>
                let (mv3, b5) := extract_moves nil b4 in
                assertion (chunk_eq chunk'' Mint32);
                assertion (eq_addressing addr addr');
                assertion (option_eq eq_addressing (offset_addressing addr (Int.repr 4)) (Some addr''));
                assertion (check_succ s b5);
                Some(BSload2 addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s)
            | _ =>
                assertion (check_succ s b3);
                if (eq_addressing addr addr') then
                  Some(BSload2_1 addr args dst mv1 args' dst' mv2 s)
                else
                 (assertion (option_eq eq_addressing (offset_addressing addr (Int.repr 4)) (Some addr'));
                  Some(BSload2_2 addr addr' args dst mv1 args' dst' mv2 s))
            end
          else (
            let (mv2, b3) := extract_moves nil b2 in
            assertion (chunk_eq chunk chunk');
            assertion (eq_addressing addr addr');
            assertion (check_succ s b3);
            Some(BSload chunk addr args dst mv1 args' dst' mv2 s))
      | _ =>
          assertion (check_succ s b1);
          Some(BSloaddead chunk addr args dst mv1 s)
      end
  | Istore chunk addr args src s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lstore chunk' addr' args' src' :: b2 =>
          if chunk_eq chunk Mint64 then
            let (mv2, b3) := extract_moves nil b2 in
            match b3 with
            | Lstore chunk'' addr'' args'' src'' :: b4 =>
                assertion (chunk_eq chunk' Mint32);
                assertion (chunk_eq chunk'' Mint32);
                assertion (eq_addressing addr addr');
                assertion (option_eq eq_addressing (offset_addressing addr (Int.repr 4)) (Some addr''));
                assertion (check_succ s b4);
                Some(BSstore2 addr addr'' args src mv1 args' src' mv2 args'' src'' s)
            | _ => None
            end
          else (
            assertion (chunk_eq chunk chunk');
            assertion (eq_addressing addr addr');
            assertion (check_succ s b2);
            Some(BSstore chunk addr args src mv1 args' src' s))
      | _ => None
      end
  | Icall sg ros args res s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lcall sg' ros' :: b2 =>
          let (mv2, b3) := extract_moves nil b2 in
          assertion (signature_eq sg sg');
          assertion (check_succ s b3);
          Some(BScall sg ros args res mv1 ros' mv2 s)
      | _ => None
      end
  | Itailcall sg ros args =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Ltailcall sg' ros' :: b2 =>
          assertion (signature_eq sg sg');
          Some(BStailcall sg ros args mv1 ros')
      | _ => None
      end
  | Ibuiltin ef args res s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lbuiltin ef' args' res' :: b2 =>
          let (mv2, b3) := extract_moves nil b2 in
          assertion (builtin_eq ef ef');
          assertion (check_succ s b3);
          Some(BSbuiltin ef args res mv1 args' res' mv2 s)
      | Lannot ef' args' :: b2 =>
          assertion (builtin_eq ef ef');
          assertion (check_succ s b2);
          match ef with
          | EF_annot txt typ => Some(BSannot txt typ args res mv1 args' s)
          | _ => None
          end
      | _ => None
      end
  | Icond cond args s1 s2 =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lcond cond' args' s1' s2' :: b2 =>
          assertion (eq_condition cond cond');
          assertion (peq s1 s1');
          assertion (peq s2 s2');
          Some(BScond cond args mv1 args' s1 s2)
      | _ => None
      end
  | Ijumptable arg tbl =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Ljumptable arg' tbl' :: b2 =>
          assertion (list_eq_dec peq tbl tbl');
          Some(BSjumptable arg mv1 arg' tbl)
      | _ => None
      end
  | Ireturn arg =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lreturn :: b2 => Some(BSreturn arg mv1)
      | _ => None
      end
  end.

(** Check all instructions of the RTL function [f1] against the corresponding
  basic blocks of LTL function [f2].  Return a map from CFG nodes to
  [block_shape] info. *)

Definition pair_codes (f1: RTL.function) (f2: LTL.function) : PTree.t block_shape :=
  PTree.combine
    (fun opti optb => do i <- opti; do b <- optb; pair_instr_block i b)
    (RTL.fn_code f1) (LTL.fn_code f2).

(** Check the entry point code of the LTL function [f2].  It must be
  a sequence of moves that branches to the same node as the entry point
  of RTL function [f1]. *)

Definition pair_entrypoints (f1: RTL.function) (f2: LTL.function) : option moves :=
  do b <- (LTL.fn_code f2)!(LTL.fn_entrypoint f2);
  let (mv, b1) := extract_moves nil b in
  assertion (check_succ (RTL.fn_entrypoint f1) b1);
  Some mv.

(** * Representing sets of equations between RTL registers and LTL locations. *)

(** The Rideau-Leroy validation algorithm manipulates sets of equations of
  the form [pseudoreg = location [kind]], meaning:
- if [kind = Full], the value of [location] in the generated LTL code is
  the same as (or more defined than) the value of [pseudoreg] in the original
  RTL code;
- if [kind = Low], the value of [location] in the generated LTL code is
  the same as (or more defined than) the low 32 bits of the 64-bit
  integer value of [pseudoreg] in the original RTL code;
- if [kind = High], the value of [location] in the generated LTL code is
  the same as (or more defined than) the high 32 bits of the 64-bit
  integer value of [pseudoreg] in the original RTL code.
*)

Inductive equation_kind : Type := Full | Low | High.

Record equation := Eq {
  ekind: equation_kind;
  ereg: reg;
  eloc: loc
}.

(** We use AVL finite sets to represent sets of equations.  Therefore, we need
  total orders over equations and their components. *)

Module IndexedEqKind <: INDEXED_TYPE.
  Definition t := equation_kind.
  Definition index (x: t) :=
    match x with Full => 1%positive | Low => 2%positive | High => 3%positive end.
  Lemma index_inj: forall x y, index x = index y -> x = y.
  Proof. destruct x; destruct y; simpl; congruence. Qed.
  Definition eq (x y: t) : {x=y} + {x<>y}.
  Proof. decide equality. Defined.
End IndexedEqKind.

Module OrderedEqKind := OrderedIndexed(IndexedEqKind).

(** This is an order over equations that is lexicographic on [ereg], then
  [eloc], then [ekind]. *)

Module OrderedEquation <: OrderedType.
  Definition t := equation.
  Definition eq (x y: t) := x = y.
  Definition lt (x y: t) :=
    Plt (ereg x) (ereg y) \/ (ereg x = ereg y /\
    (OrderedLoc.lt (eloc x) (eloc y) \/ (eloc x = eloc y /\
    OrderedEqKind.lt (ekind x) (ekind y)))).
  Lemma eq_refl : forall x : t, eq x x.
  Proof (@refl_equal t).
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof (@sym_equal t).
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof (@trans_equal t).
  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros.
    destruct H.
    destruct H0. left; eapply Plt_trans; eauto.
    destruct H0. rewrite <- H0. auto.
    destruct H. rewrite H.
    destruct H0. auto.
    destruct H0. right; split; auto.
    intuition.
    left; eapply OrderedLoc.lt_trans; eauto.
    left; congruence.
    left; congruence.
    right; split. congruence. eapply OrderedEqKind.lt_trans; eauto.
  Qed.
  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    unfold lt, eq; intros; red; intros. subst y. intuition.
    eelim Plt_strict; eauto.
    eelim OrderedLoc.lt_not_eq; eauto. red; auto.
    eelim OrderedEqKind.lt_not_eq; eauto. red; auto.
  Qed.
  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    intros.
    destruct (OrderedPositive.compare (ereg x) (ereg y)).
  - apply LT. red; auto.
  - destruct (OrderedLoc.compare (eloc x) (eloc y)).
    + apply LT. red; auto.
    + destruct (OrderedEqKind.compare (ekind x) (ekind y)).
      * apply LT. red; auto.
      * apply EQ. red in e; red in e0; red in e1; red.
        destruct x; destruct y; simpl in *; congruence.
      * apply GT. red; auto.
   + apply GT. red; auto.
  - apply GT. red; auto.
  Defined.
  Definition eq_dec (x y: t) : {x = y} + {x <> y}.
  Proof.
    intros. decide equality.
    apply Loc.eq.
    apply peq.
    apply IndexedEqKind.eq.
  Defined.
End OrderedEquation.

(** This is an alternate order over equations that is lexicgraphic on
  [eloc], then [ereg], then [ekind]. *)

Module OrderedEquation' <: OrderedType.
  Definition t := equation.
  Definition eq (x y: t) := x = y.
  Definition lt (x y: t) :=
    OrderedLoc.lt (eloc x) (eloc y) \/ (eloc x = eloc y /\
    (Plt (ereg x) (ereg y) \/ (ereg x = ereg y /\
    OrderedEqKind.lt (ekind x) (ekind y)))).
  Lemma eq_refl : forall x : t, eq x x.
  Proof (@refl_equal t).
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof (@sym_equal t).
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof (@trans_equal t).
  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros.
    destruct H.
    destruct H0. left; eapply OrderedLoc.lt_trans; eauto.
    destruct H0. rewrite <- H0. auto.
    destruct H. rewrite H.
    destruct H0. auto.
    destruct H0. right; split; auto.
    intuition.
    left; eapply Plt_trans; eauto.
    left; congruence.
    left; congruence.
    right; split. congruence. eapply OrderedEqKind.lt_trans; eauto.
  Qed.
  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    unfold lt, eq; intros; red; intros. subst y. intuition.
    eelim OrderedLoc.lt_not_eq; eauto. red; auto.
    eelim Plt_strict; eauto.
    eelim OrderedEqKind.lt_not_eq; eauto. red; auto.
  Qed.
  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    intros.
    destruct (OrderedLoc.compare (eloc x) (eloc y)).
  - apply LT. red; auto.
  - destruct (OrderedPositive.compare (ereg x) (ereg y)).
    + apply LT. red; auto.
    + destruct (OrderedEqKind.compare (ekind x) (ekind y)).
      * apply LT. red; auto.
      * apply EQ. red in e; red in e0; red in e1; red.
        destruct x; destruct y; simpl in *; congruence.
      * apply GT. red; auto.
   + apply GT. red; auto.
  - apply GT. red; auto.
  Defined.
  Definition eq_dec: forall (x y: t), {x = y} + {x <> y} := OrderedEquation.eq_dec.
End OrderedEquation'.

Module EqSet := FSetAVLplus.Make(OrderedEquation).
Module EqSet2 := FSetAVLplus.Make(OrderedEquation').

(** We use a redundant representation for sets of equations, comprising
  two AVL finite sets, containing the same elements, but ordered along
  the two orders defined above.  Playing on properties of lexicographic
  orders, this redundant representation enables us to quickly find
  all equations involving a given RTL pseudoregister, or all equations
  involving a given LTL location or overlapping location. *)

Record eqs := mkeqs {
  eqs1 :> EqSet.t;
  eqs2 : EqSet2.t;
  eqs_same: forall q, EqSet2.In q eqs2 <-> EqSet.In q eqs1
}.

(** * Operations on sets of equations *)

(** The empty set of equations. *)

Program Definition empty_eqs := mkeqs EqSet.empty EqSet2.empty _.
Next Obligation.
  split; intros. eelim EqSet2.empty_1; eauto. eelim EqSet.empty_1; eauto.
Qed.

(** Adding or removing an equation from a set. *)

Program Definition add_equation (q: equation) (e: eqs) :=
  mkeqs (EqSet.add q (eqs1 e)) (EqSet2.add q (eqs2 e)) _.
Next Obligation.
  split; intros.
  destruct (OrderedEquation'.eq_dec q q0).
  apply EqSet.add_1; auto.
  apply EqSet.add_2. apply (eqs_same e). apply EqSet2.add_3 with q; auto.
  destruct (OrderedEquation.eq_dec q q0).
  apply EqSet2.add_1; auto.
  apply EqSet2.add_2. apply (eqs_same e). apply EqSet.add_3 with q; auto.
Qed.

Program Definition remove_equation (q: equation) (e: eqs) :=
  mkeqs (EqSet.remove q (eqs1 e)) (EqSet2.remove q (eqs2 e)) _.
Next Obligation.
  split; intros.
  destruct (OrderedEquation'.eq_dec q q0).
  eelim EqSet2.remove_1; eauto.
  apply EqSet.remove_2; auto. apply (eqs_same e). apply EqSet2.remove_3 with q; auto.
  destruct (OrderedEquation.eq_dec q q0).
  eelim EqSet.remove_1; eauto.
  apply EqSet2.remove_2; auto. apply (eqs_same e). apply EqSet.remove_3 with q; auto.
Qed.

(** [reg_unconstrained r e] is true if [e] contains no equations involving
  the RTL pseudoregister [r].  In other words, all equations [r' = l [kind]]
  in [e] are such that [r' <> r]. *)

Definition select_reg_l (r: reg) (q: equation) := Pos.leb r (ereg q).
Definition select_reg_h (r: reg) (q: equation) := Pos.leb (ereg q) r.

Definition reg_unconstrained (r: reg) (e: eqs) : bool :=
  negb (EqSet.mem_between (select_reg_l r) (select_reg_h r) (eqs1 e)).

(** [loc_unconstrained l e] is true if [e] contains no equations involving
  the LTL location [l] or a location that partially overlaps with [l].
  In other words, all equations [r = l' [kind]] in [e] are such that
  [Loc.diff l' l]. *)

Definition select_loc_l (l: loc) :=
  let lb := OrderedLoc.diff_low_bound l in
  fun (q: equation) => match OrderedLoc.compare (eloc q) lb with LT _ => false | _ => true end.
Definition select_loc_h (l: loc) :=
  let lh := OrderedLoc.diff_high_bound l in
  fun (q: equation) => match OrderedLoc.compare (eloc q) lh with GT _ => false | _ => true end.

Definition loc_unconstrained (l: loc) (e: eqs) : bool :=
  negb (EqSet2.mem_between (select_loc_l l) (select_loc_h l) (eqs2 e)).

Definition reg_loc_unconstrained (r: reg) (l: loc) (e: eqs) : bool :=
  reg_unconstrained r e && loc_unconstrained l e.

(** [subst_reg r1 r2 e] simulates the effect of assigning [r2] to [r1] on [e].
  All equations of the form [r1 = l [kind]] are replaced by [r2 = l [kind]].
*)

Definition subst_reg (r1 r2: reg) (e: eqs) : eqs :=
  EqSet.fold
    (fun q e => add_equation (Eq (ekind q) r2 (eloc q)) (remove_equation q e))
    (EqSet.elements_between (select_reg_l r1) (select_reg_h r1) (eqs1 e))
    e.

(** [subst_reg_kind r1 k1 r2 k2 e] simulates the effect of assigning
  the [k2] part of [r2] to the [k1] part of [r1] on [e].
  All equations of the form [r1 = l [k1]] are replaced by [r2 = l [k2]].
*)

Definition subst_reg_kind (r1: reg) (k1: equation_kind) (r2: reg) (k2: equation_kind) (e: eqs) : eqs :=
  EqSet.fold
    (fun q e =>
      if IndexedEqKind.eq (ekind q) k1
      then add_equation (Eq k2 r2 (eloc q)) (remove_equation q e)
      else e)
    (EqSet.elements_between (select_reg_l r1) (select_reg_h r1) (eqs1 e))
    e.

(** [subst_loc l1 l2 e] simulates the effect of assigning [l2] to [l1] on [e].
  All equations of the form [r = l1 [kind]] are replaced by [r = l2 [kind]].
  Return [None] if [e] contains an equation of the form [r = l] with [l]
  partially overlapping [l1].
*)

Definition subst_loc (l1 l2: loc) (e: eqs) : option eqs :=
  EqSet2.fold
    (fun q opte =>
      match opte with
      | None => None
      | Some e =>
          if Loc.eq l1 (eloc q) then
            Some (add_equation (Eq (ekind q) (ereg q) l2) (remove_equation q e))
          else
            None
      end)
     (EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e))
     (Some e).

(** [loc_type_compat env l e] checks that for all equations [r = l] in [e],
  the type [env r] of [r] is compatible with the type of [l]. *)

Definition sel_type (k: equation_kind) (ty: typ) : typ :=
  match k with
  | Full => ty
  | Low | High => Tint
  end.

Definition loc_type_compat (env: regenv) (l: loc) (e: eqs) : bool :=
  EqSet2.for_all_between
    (fun q => subtype (sel_type (ekind q) (env (ereg q))) (Loc.type l))
    (select_loc_l l) (select_loc_h l) (eqs2 e).

(** [add_equations [r1...rN] [m1...mN] e] adds to [e] the [N] equations
    [ri = R mi [Full]].  Return [None] if the two lists have different lengths.
*)

Fixpoint add_equations (rl: list reg) (ml: list mreg) (e: eqs) : option eqs :=
  match rl, ml with
  | nil, nil => Some e
  | r1 :: rl, m1 :: ml => add_equations rl ml (add_equation (Eq Full r1 (R m1)) e)
  | _, _ => None
  end.

(** [add_equations_args] is similar but additionally handles the splitting
  of pseudoregisters of type [Tlong] in two locations containing the
  two 32-bit halves of the 64-bit integer. *)

Function add_equations_args (rl: list reg) (tyl: list typ) (ll: list loc) (e: eqs) : option eqs :=
  match rl, tyl, ll with
  | nil, nil, nil => Some e
  | r1 :: rl, Tlong :: tyl, l1 :: l2 :: ll =>
      add_equations_args rl tyl ll (add_equation (Eq Low r1 l2) (add_equation (Eq High r1 l1) e))
  | r1 :: rl, (Tint|Tfloat|Tsingle) :: tyl, l1 :: ll =>
      add_equations_args rl tyl ll (add_equation (Eq Full r1 l1) e)
  | _, _, _ => None
  end.

(** [add_equations_res] is similar but is specialized to the case where
  there is only one pseudo-register. *)

Function add_equations_res (r: reg) (oty: option typ) (ll: list loc) (e: eqs) : option eqs :=
  match oty with
  | Some Tlong =>
      match ll with
      | l1 :: l2 :: nil => Some (add_equation (Eq Low r l2) (add_equation (Eq High r l1) e))
      | _ => None
      end
  | _ =>
      match ll with
      | l1 :: nil => Some (add_equation (Eq Full r l1) e)
      | _ => None
      end
  end.

(** [remove_equations_res] is similar to [add_equations_res] but removes
  equations instead of adding them. *)

Function remove_equations_res (r: reg) (oty: option typ) (ll: list loc) (e: eqs) : option eqs :=
  match oty with
  | Some Tlong =>
      match ll with
      | l1 :: l2 :: nil =>
          if Loc.diff_dec l2 l1
          then Some (remove_equation (Eq Low r l2) (remove_equation (Eq High r l1) e))
          else None
      | _ => None
      end
  | _ =>
      match ll with
      | l1 :: nil => Some (remove_equation (Eq Full r l1) e)
      | _ => None
      end
  end.

(** [add_equations_ros] adds an equation, if needed, between an optional
  pseudoregister and an optional machine register.  It is used for the
  function argument of the [Icall] and [Itailcall] instructions. *)

Definition add_equation_ros (ros: reg + ident) (ros': mreg + ident) (e: eqs) : option eqs :=
  match ros, ros' with
  | inl r, inl mr => Some(add_equation (Eq Full r (R mr)) e)
  | inr id, inr id' => assertion (ident_eq id id'); Some e
  | _, _ => None
  end.

(** [can_undef ml] returns true if all machine registers in [ml] are
  unconstrained and can harmlessly be undefined. *)

Fixpoint can_undef (ml: list mreg) (e: eqs) : bool :=
  match ml with
  | nil => true
  | m1 :: ml => loc_unconstrained (R m1) e && can_undef ml e
  end.

Fixpoint can_undef_except (l: loc) (ml: list mreg) (e: eqs) : bool :=
  match ml with
  | nil => true
  | m1 :: ml =>
      (Loc.eq l (R m1) || loc_unconstrained (R m1) e) && can_undef_except l ml e
  end.

(** [no_caller_saves e] returns [e] if all caller-save locations are
  unconstrained in [e].  In other words, [e] contains no equations
  involving a caller-save register or [Outgoing] stack slot. *)

Definition no_caller_saves (e: eqs) : bool :=
  EqSet.for_all
   (fun eq =>
     match eloc eq with
       | R r =>
           zle 0 (index_int_callee_save r) || zle 0 (index_float_callee_save r)
       | S Outgoing _ _ => false
       | S _ _ _ => true
       end)
    e.

(** [compat_left r l e] returns true if all equations in [e] that involve
    [r] are of the form [r = l [Full]]. *)

Definition compat_left (r: reg) (l: loc) (e: eqs) : bool :=
  EqSet.for_all_between
    (fun q =>
        match ekind q with
        | Full => Loc.eq l (eloc q)
        | _ => false
        end)
    (select_reg_l r) (select_reg_h r)
    (eqs1 e).

(** [compat_left2 r l1 l2 e] returns true if all equations in [e] that involve
    [r] are of the form [r = l1 [High]] or [r = l2 [Low]]. *)

Definition compat_left2 (r: reg) (l1 l2: loc) (e: eqs) : bool :=
  EqSet.for_all_between
    (fun q =>
        match ekind q with
        | High => Loc.eq l1 (eloc q)
        | Low => Loc.eq l2 (eloc q)
        | _ => false
        end)
    (select_reg_l r) (select_reg_h r)
    (eqs1 e).

(** [ros_compatible_tailcall ros] returns true if [ros] is a function
  name or a caller-save register.  This is used to check [Itailcall]
  instructions. *)

Definition ros_compatible_tailcall (ros: mreg + ident) : bool :=
  match ros with
  | inl r => In_dec mreg_eq r destroyed_at_call
  | inr id => true
  end.

(** * The validator *)

Definition destroyed_by_move (src dst: loc) :=
  match src, dst with
  | S sl ofs ty, _ => destroyed_by_getstack sl
  | _, S sl ofs ty => destroyed_by_setstack ty
  | _, _ => destroyed_by_op Omove
  end.

Definition well_typed_move (env: regenv) (dst: loc) (e: eqs) : bool :=
  match dst with
  | R r => true
  | S sl ofs ty => loc_type_compat env dst e
  end.

(** Simulate the effect of a sequence of moves [mv] on a set of
  equations [e].  The set [e] is the equations that must hold
  after the sequence of moves.  Return the set of equations that
  must hold before the sequence of moves.  Return [None] if the
  set of equations [e] cannot hold after the sequence of moves. *)

Fixpoint track_moves (env: regenv) (mv: moves) (e: eqs) : option eqs :=
  match mv with
  | nil => Some e
  | (src, dst) :: mv =>
      do e1 <- track_moves env mv e;
      assertion (can_undef_except dst (destroyed_by_move src dst)) e1;
      assertion (well_typed_move env dst e1);
      subst_loc dst src e1
  end.

(** [transfer_use_def args res args' res' undefs e] returns the set
  of equations that must hold "before" in order for the equations [e]
  to hold "after" the execution of RTL and LTL code of the following form:
<<
                RTL                            LTL
         use pseudoregs args            use machine registers args'
         define pseudoreg res           undefine machine registers undef
                                        define machine register res'
>>
  As usual, [None] is returned if the equations [e] cannot hold after
  this execution.
*)

Definition transfer_use_def (args: list reg) (res: reg) (args': list mreg) (res': mreg)
                            (undefs: list mreg) (e: eqs) : option eqs :=
  let e1 := remove_equation (Eq Full res (R res')) e in
  assertion (reg_loc_unconstrained res (R res') e1);
  assertion (can_undef undefs e1);
  add_equations args args' e1.

Definition kind_first_word := if Archi.big_endian then High else Low.
Definition kind_second_word := if Archi.big_endian then Low else High.

(** The core transfer function.  It takes a set [e] of equations that must
  hold "after" and a block shape [shape] representing a matching pair
  of an RTL instruction and an LTL basic block.  It returns the set of
  equations that must hold "before" these instructions, or [None] if
  impossible. *)

Definition transfer_aux (f: RTL.function) (env: regenv)
                        (shape: block_shape) (e: eqs) : option eqs :=
  match shape with
  | BSnop mv s =>
      track_moves env mv e
  | BSmove src dst mv s =>
      track_moves env mv (subst_reg dst src e)
  | BSmakelong src1 src2 dst mv s =>
      let e1 := subst_reg_kind dst High src1 Full e in
      let e2 := subst_reg_kind dst Low src2 Full e1 in
      assertion (reg_unconstrained dst e2);
      track_moves env mv e2
  | BSlowlong src dst mv s =>
      let e1 := subst_reg_kind dst Full src Low e in
      assertion (reg_unconstrained dst e1);
      track_moves env mv e1
  | BShighlong src dst mv s =>
      let e1 := subst_reg_kind dst Full src High e in
      assertion (reg_unconstrained dst e1);
      track_moves env mv e1
  | BSop op args res mv1 args' res' mv2 s =>
      do e1 <- track_moves env mv2 e;
      do e2 <- transfer_use_def args res args' res' (destroyed_by_op op) e1;
      track_moves env mv1 e2
  | BSopdead op args res mv s =>
      assertion (reg_unconstrained res e);
      track_moves env mv e
  | BSload chunk addr args dst mv1 args' dst' mv2 s =>
      do e1 <- track_moves env mv2 e;
      do e2 <- transfer_use_def args dst args' dst' (destroyed_by_load chunk addr) e1;
      track_moves env mv1 e2
  | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s =>
      do e1 <- track_moves env mv3 e;
      let e2 := remove_equation (Eq kind_second_word dst (R dst2')) e1 in
      assertion (loc_unconstrained (R dst2') e2);
      assertion (can_undef (destroyed_by_load Mint32 addr') e2);
      do e3 <- add_equations args args2' e2;
      do e4 <- track_moves env mv2 e3;
      let e5 := remove_equation (Eq kind_first_word dst (R dst1')) e4 in
      assertion (loc_unconstrained (R dst1') e5);
      assertion (can_undef (destroyed_by_load Mint32 addr) e5);
      assertion (reg_unconstrained dst e5);
      do e6 <- add_equations args args1' e5;
      track_moves env mv1 e6
  | BSload2_1 addr args dst mv1 args' dst' mv2 s =>
      do e1 <- track_moves env mv2 e;
      let e2 := remove_equation (Eq kind_first_word dst (R dst')) e1 in
      assertion (reg_loc_unconstrained dst (R dst') e2);
      assertion (can_undef (destroyed_by_load Mint32 addr) e2);
      do e3 <- add_equations args args' e2;
      track_moves env mv1 e3
  | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s =>
      do e1 <- track_moves env mv2 e;
      let e2 := remove_equation (Eq kind_second_word dst (R dst')) e1 in
      assertion (reg_loc_unconstrained dst (R dst') e2);
      assertion (can_undef (destroyed_by_load Mint32 addr') e2);
      do e3 <- add_equations args args' e2;
      track_moves env mv1 e3
  | BSloaddead chunk addr args dst mv s =>
      assertion (reg_unconstrained dst e);
      track_moves env mv e
  | BSstore chunk addr args src mv args' src' s =>
      assertion (can_undef (destroyed_by_store chunk addr) e);
      do e1 <- add_equations (src :: args) (src' :: args') e;
      track_moves env mv e1
  | BSstore2 addr addr' args src mv1 args1' src1' mv2 args2' src2' s =>
      assertion (can_undef (destroyed_by_store Mint32 addr') e);
      do e1 <- add_equations args args2'
                  (add_equation (Eq kind_second_word src (R src2')) e);
      do e2 <- track_moves env mv2 e1;
      assertion (can_undef (destroyed_by_store Mint32 addr) e2);
      do e3 <- add_equations args args1'
                  (add_equation (Eq kind_first_word src (R src1')) e2);
      track_moves env mv1 e3
  | BScall sg ros args res mv1 ros' mv2 s =>
      let args' := loc_arguments sg in
      let res' := map R (loc_result sg) in
      do e1 <- track_moves env mv2 e;
      do e2 <- remove_equations_res res (sig_res sg) res' e1;
      assertion (forallb (fun l => reg_loc_unconstrained res l e2) res');
      assertion (no_caller_saves e2);
      do e3 <- add_equation_ros ros ros' e2;
      do e4 <- add_equations_args args (sig_args sg) args' e3;
      track_moves env mv1 e4
  | BStailcall sg ros args mv1 ros' =>
      let args' := loc_arguments sg in
      assertion (tailcall_is_possible sg);
      assertion (opt_typ_eq sg.(sig_res) f.(RTL.fn_sig).(sig_res));
      assertion (ros_compatible_tailcall ros');
      do e1 <- add_equation_ros ros ros' empty_eqs;
      do e2 <- add_equations_args args (sig_args sg) args' e1;
      track_moves env mv1 e2
  | BSbuiltin ef args res mv1 args' res' mv2 s =>
      do e1 <- track_moves env mv2 e;
      let args' := map R args' in
      let res' := map R res' in
      do e2 <- remove_equations_res res (sig_res (builtin_sig ef)) res' e1;
      assertion (reg_unconstrained res e2);
      assertion (forallb (fun l => loc_unconstrained l e2) res');
      assertion (can_undef (destroyed_by_builtin ef) e2);
      do e3 <- add_equations_args args (sig_args (builtin_sig ef)) args' e2;
      track_moves env mv1 e3
  | BSannot txt typ args res mv1 args' s =>
      do e1 <- add_equations_args args (annot_args_typ typ) args' e;
      track_moves env mv1 e1
  | BScond cond args mv args' s1 s2 =>
      assertion (can_undef (destroyed_by_cond cond) e);
      do e1 <- add_equations args args' e;
      track_moves env mv e1
  | BSjumptable arg mv arg' tbl =>
      assertion (can_undef destroyed_by_jumptable e);
      track_moves env mv (add_equation (Eq Full arg (R arg')) e)
  | BSreturn None mv =>
      track_moves env mv empty_eqs
  | BSreturn (Some arg) mv =>
      let arg' := map R (loc_result (RTL.fn_sig f)) in
      do e1 <- add_equations_res arg (sig_res (RTL.fn_sig f)) arg' empty_eqs;
      track_moves env mv e1
  end.

(** The main transfer function for the dataflow analysis.  Like [transfer_aux],
  it infers the equations that must hold "before" as a function of the
  equations that must hold "after".  It also handles error propagation
  and reporting. *)

Definition transfer (f: RTL.function) (env: regenv) (shapes: PTree.t block_shape)
                    (pc: node) (after: res eqs) : res eqs :=
  match after with
  | Error _ => after
  | OK e =>
      match shapes!pc with
      | None => Error(MSG "At PC " :: POS pc :: MSG ": unmatched block" :: nil)
      | Some shape =>
          match transfer_aux f env shape e with
          | None => Error(MSG "At PC " :: POS pc :: MSG ": invalid register allocation" :: nil)
          | Some e' => OK e'
          end
      end
  end.

(** The semilattice for dataflow analysis.  Operates on analysis results
  of type [res eqs], that is, either a set of equations or an error
  message.  Errors correspond to [Top].  Sets of equations are ordered
  by inclusion. *)

Module LEq <: SEMILATTICE.

  Definition t := res eqs.

  Definition eq (x y: t) :=
    match x, y with
    | OK a, OK b => EqSet.Equal a b
    | Error _, Error _ => True
    | _, _ => False
    end.

  Lemma eq_refl: forall x, eq x x.
  Proof.
    intros; destruct x; simpl; auto. red; tauto.
  Qed.

  Lemma eq_sym: forall x y, eq x y -> eq y x.
  Proof.
    unfold eq; intros; destruct x; destruct y; auto.
    red in H; red; intros. rewrite H; tauto.
  Qed.

  Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Proof.
    unfold eq; intros. destruct x; destruct y; try contradiction; destruct z; auto.
    red in H; red in H0; red; intros. rewrite H. auto.
  Qed.

  Definition beq (x y: t) :=
    match x, y with
    | OK a, OK b => EqSet.equal a b
    | Error _, Error _ => true
    | _, _ => false
    end.

  Lemma beq_correct: forall x y, beq x y = true -> eq x y.
  Proof.
    unfold beq, eq; intros. destruct x; destruct y.
    apply EqSet.equal_2. auto.
    discriminate.
    discriminate.
    auto.
  Qed.

  Definition ge (x y: t) :=
    match x, y with
    | OK a, OK b => EqSet.Subset b a
    | Error _, _ => True
    | _, Error _ => False
    end.

  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge, EqSet.Equal, EqSet.Subset; intros.
    destruct x; destruct y; auto. intros; rewrite H; auto.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge, EqSet.Subset; intros.
    destruct x; auto; destruct y; try contradiction.
    destruct z; eauto.
  Qed.

  Definition bot: t := OK empty_eqs.

  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot, EqSet.Subset; simpl; intros.
    destruct x; auto. intros. elim (EqSet.empty_1 H).
  Qed.

  Program Definition lub (x y: t) : t :=
    match x, y return _ with
    | OK a, OK b =>
        OK (mkeqs (EqSet.union (eqs1 a) (eqs1 b))
                  (EqSet2.union (eqs2 a) (eqs2 b)) _)
    | OK _, Error _ => y
    | Error _, _ => x
    end.
  Next Obligation.
    split; intros.
    apply EqSet2.union_1 in H. destruct H; rewrite eqs_same in H.
    apply EqSet.union_2; auto. apply EqSet.union_3; auto.
    apply EqSet.union_1 in H. destruct H; rewrite <- eqs_same in H.
    apply EqSet2.union_2; auto. apply EqSet2.union_3; auto.
  Qed.

  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold lub, ge, EqSet.Subset; intros.
    destruct x; destruct y; auto.
    intros; apply EqSet.union_2; auto.
  Qed.

  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold lub, ge, EqSet.Subset; intros.
    destruct x; destruct y; auto.
    intros; apply EqSet.union_3; auto.
  Qed.

End LEq.

(** The backward dataflow solver is an instantiation of Kildall's algorithm. *)

Module DS := Backward_Dataflow_Solver(LEq)(NodeSetBackward).

(** The control-flow graph that the solver operates on is the CFG of
  block shapes built by the structural check phase.  Here is its notion
  of successors. *)

Definition successors_block_shape (bsh: block_shape) : list node :=
  match bsh with
  | BSnop mv s => s :: nil
  | BSmove src dst mv s => s :: nil
  | BSmakelong src1 src2 dst mv s => s :: nil
  | BSlowlong src dst mv s => s :: nil
  | BShighlong src dst mv s => s :: nil
  | BSop op args res mv1 args' res' mv2 s => s :: nil
  | BSopdead op args res mv s => s :: nil
  | BSload chunk addr args dst mv1 args' dst' mv2 s => s :: nil
  | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => s :: nil
  | BSload2_1 addr args dst mv1 args' dst' mv2 s => s :: nil
  | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s => s :: nil
  | BSloaddead chunk addr args dst mv s => s :: nil
  | BSstore chunk addr args src mv1 args' src' s => s :: nil
  | BSstore2 addr addr' args src mv1 args1' src1' mv2 args2' src2' s => s :: nil
  | BScall sg ros args res mv1 ros' mv2 s => s :: nil
  | BStailcall sg ros args mv1 ros' => nil
  | BSbuiltin ef args res mv1 args' res' mv2 s => s :: nil
  | BSannot txt typ args res mv1 args' s => s :: nil
  | BScond cond args mv args' s1 s2 => s1 :: s2 :: nil
  | BSjumptable arg mv arg' tbl => tbl
  | BSreturn optarg mv => nil
  end.

Definition analyze (f: RTL.function) (env: regenv) (bsh: PTree.t block_shape) :=
  DS.fixpoint_allnodes bsh successors_block_shape (transfer f env bsh).

(** * Validating and translating functions and programs *)

(** Checking equations at function entry point.  The RTL function receives
  its arguments in the list [rparams] of pseudoregisters.  The LTL function
  receives them in the list [lparams] of locations dictated by the
  calling conventions, with arguments of type [Tlong] being split in
  two 32-bit halves.  We check that the equations [e] that must hold
  at the beginning of the functions are compatible with these calling
  conventions, in the sense that all equations involving a pseudoreg
  [r] from [rparams] is of the form [r = l [Full]] or [r = l [Low]]
  or [r = l [High]], where [l] is the corresponding element of [lparams].

  Note that [e] can contain additional equations [r' = l [kind]]
  involving pseudoregs [r'] not in [rparams]: these equations are
  automatically satisfied since the initial value of [r'] is [Vundef]. *)

Function compat_entry (rparams: list reg) (tys: list typ) (lparams: list loc) (e: eqs)
                      {struct rparams} : bool :=
  match rparams, tys, lparams with
  | nil, nil, nil => true
  | r1 :: rl, Tlong :: tyl, l1 :: l2 :: ll =>
      compat_left2 r1 l1 l2 e && compat_entry rl tyl ll e
  | r1 :: rl, (Tint|Tfloat|Tsingle) :: tyl, l1 :: ll =>
      compat_left r1 l1 e && compat_entry rl tyl ll e
  | _, _, _ => false
  end.

(** Checking the satisfiability of equations inferred at function entry
  point.  We also check that the RTL and LTL functions agree in signature
  and stack size. *)

Definition check_entrypoints_aux (rtl: RTL.function) (ltl: LTL.function)
                                 (env: regenv) (e1: eqs) : option unit :=
  do mv <- pair_entrypoints rtl ltl;
  do e2 <- track_moves env mv e1;
  assertion (compat_entry (RTL.fn_params rtl)
                          (sig_args (RTL.fn_sig rtl))
                          (loc_parameters (RTL.fn_sig rtl)) e2);
  assertion (can_undef destroyed_at_function_entry e2);
  assertion (zeq (RTL.fn_stacksize rtl) (LTL.fn_stacksize ltl));
  assertion (signature_eq (RTL.fn_sig rtl) (LTL.fn_sig ltl));
  Some tt.

Local Close Scope option_monad_scope.
Local Open Scope error_monad_scope.

Definition check_entrypoints (rtl: RTL.function) (ltl: LTL.function)
                             (env: regenv) (bsh: PTree.t block_shape)
                             (a: PMap.t LEq.t): res unit :=
  do e1 <- transfer rtl env bsh (RTL.fn_entrypoint rtl) a!!(RTL.fn_entrypoint rtl);
  match check_entrypoints_aux rtl ltl env e1 with
  | None => Error (msg "invalid register allocation at entry point")
  | Some _ => OK tt
  end.

(** Putting it all together, this is the validation function for
  a source RTL function and an LTL function generated by the external
  register allocator. *)

Definition check_function (rtl: RTL.function) (ltl: LTL.function) (env: regenv): res unit :=
  let bsh := pair_codes rtl ltl in
  match analyze rtl env bsh with
  | None => Error (msg "allocation analysis diverges")
  | Some a => check_entrypoints rtl ltl env bsh a
  end.

(** [regalloc] is the external register allocator.  It is written in OCaml
  in file [backend/Regalloc.ml]. *)

Parameter regalloc: RTL.function -> res LTL.function.

(** Register allocation followed by validation. *)

Definition transf_function (f: RTL.function) : res LTL.function :=
  match type_function f with
  | Error m => Error m
  | OK env =>
      match regalloc f with
      | Error m => Error m
      | OK tf => do x <- check_function f tf env; OK tf
      end
  end.

Definition transf_fundef (fd: RTL.fundef) : res LTL.fundef :=
  AST.transf_partial_fundef transf_function fd.

Definition transf_program (p: RTL.program) : res LTL.program :=
  transform_partial_program transf_fundef p.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a9_ : Universe.
Variable a8_ : Universe.
Variable a7_ : Universe.
Variable a6_ : Universe.
Variable a5_ : Universe.
Variable a4_ : Universe.
Variable a38_ : Universe.
Variable a37_ : Universe.
Variable a36_ : Universe.
Variable a35_ : Universe.
Variable a34_ : Universe.
Variable a33_ : Universe.
Variable a32_ : Universe.
Variable a31_ : Universe.
Variable a30_ : Universe.
Variable a3_ : Universe.
Variable a29_ : Universe.
Variable a28_ : Universe.
Variable a27_ : Universe.
Variable a26_ : Universe.
Variable a25_ : Universe.
Variable a24_ : Universe.
Variable a23_ : Universe.
Variable a22_ : Universe.
Variable a21_ : Universe.
Variable a20_ : Universe.
Variable a2_ : Universe.
Variable a19_ : Universe.
Variable a18_ : Universe.
Variable a17_ : Universe.
Variable a16_ : Universe.
Variable a15_ : Universe.
Variable a14_ : Universe.
Variable a13_ : Universe.
Variable a12_ : Universe.
Variable a11_ : Universe.
Variable a10_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ a4_ /\ (dom_ a5_ /\ (dom_ a6_ /\ (dom_ a7_ /\ (dom_ a8_ /\ (dom_ a9_ /\ (dom_ a10_ /\ (dom_ a11_ /\ (dom_ a12_ /\ (dom_ a13_ /\ (dom_ a14_ /\ (dom_ a15_ /\ (dom_ a16_ /\ (dom_ a17_ /\ (dom_ a18_ /\ (dom_ a19_ /\ (dom_ a20_ /\ (dom_ a21_ /\ (dom_ a22_ /\ (dom_ a23_ /\ (dom_ a24_ /\ (dom_ a25_ /\ (dom_ a26_ /\ (dom_ a27_ /\ (dom_ a28_ /\ (dom_ a29_ /\ (dom_ a30_ /\ (dom_ a31_ /\ (dom_ a32_ /\ (dom_ a33_ /\ (dom_ a34_ /\ (dom_ a35_ /\ (dom_ a36_ /\ (dom_ a37_ /\ dom_ a38_))))))))))))))))))))))))))))))))))))).
Variable ax2_2 : (forall A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21 A22 A23 A24 A25 A26 A27 A28 A29 A30 A31 A32 A33 A34 A35 A36 A37 A38 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ (dom_ A4 /\ (dom_ A5 /\ (dom_ A6 /\ (dom_ A7 /\ (dom_ A8 /\ (dom_ A9 /\ (dom_ A10 /\ (dom_ A11 /\ (dom_ A12 /\ (dom_ A13 /\ (dom_ A14 /\ (dom_ A15 /\ (dom_ A16 /\ (dom_ A17 /\ (dom_ A18 /\ (dom_ A19 /\ (dom_ A20 /\ (dom_ A21 /\ (dom_ A22 /\ (dom_ A23 /\ (dom_ A24 /\ (dom_ A25 /\ (dom_ A26 /\ (dom_ A27 /\ (dom_ A28 /\ (dom_ A29 /\ (dom_ A30 /\ (dom_ A31 /\ (dom_ A32 /\ (dom_ A33 /\ (dom_ A34 /\ (dom_ A35 /\ (dom_ A36 /\ (dom_ A37 /\ dom_ A38))))))))))))))))))))))))))))))))))))) -> p_ A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21 A22 A23 A24 A25 A26 A27 A28 A29 A30 A31 A32 A33 A34 A35 A36 A37 A38)).
Variable ax3_3 : (p_ a38_ a37_ a36_ a35_ a34_ a33_ a32_ a31_ a30_ a29_ a28_ a27_ a26_ a25_ a24_ a23_ a22_ a21_ a20_ a19_ a18_ a17_ a16_ a15_ a14_ a13_ a12_ a11_ a10_ a9_ a8_ a7_ a6_ a5_ a4_ a3_ a2_ a1_ -> goal_).

Theorem lemma38_4 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


(* Uniqueness of Typing *)

From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From MetaCoq Require Import Ast utils Typing.
From Translation
Require Import util SAst SLiftSubst Equality SCommon Conversion ITyping
               ITypingInversions ITypingLemmata ContextConversion.
Import ListNotations.

Section Uniqueness.

Context `{Sort_notion : Sorts.notion}.

Ltac unitac h1 h2 :=
  ttinv h1 ; ttinv h2 ;
  eapply conv_trans ; [
    eapply conv_sym ; eassumption
  | idtac
  ].

Lemma uniqueness :
  forall {Σ Γ A B u},
    type_glob Σ ->
    Σ ;;; Γ |-i u : A ->
    Σ ;;; Γ |-i u : B ->
    A ≡ B.
Proof.
  intros Σ Γ A B u hg h1 h2.
  revert Γ A B h1 h2.
  induction u ; intros Γ A B h1 h2.
  all: try unitac h1 h2. all: try assumption.
  - cbn in *. erewrite @safe_nth_irr with (isdecl' := is) in h0. assumption.
  - specialize (IHu1 _ _ _ h0 h5).
    specialize (IHu2 _ _ _ h h3).
    eapply conv_trans. 2: eapply h7.
    pose proof (sort_conv_inv IHu1) as e1.
    pose proof (sort_conv_inv IHu2) as e2.
    subst. apply conv_refl.
  - eapply nl_conv ; try eassumption ; reflexivity.
  - specialize (IHu1 _ _ _ h0 h5).
    specialize (IHu2 _ _ _ h h3).
    eapply conv_trans. 2: eapply h7.
    pose proof (sort_conv_inv IHu1) as e1.
    pose proof (sort_conv_inv IHu2) as e2.
    subst. apply conv_refl.
  - eapply conv_trans ; [| exact h11 ].
    apply cong_Sum ; apply conv_refl.
  - specialize (IHu1 _ _ _ h0 h6).
    pose proof (sort_conv_inv IHu1) as e. subst. assumption.
  - specialize (IHu1 _ _ _ h0 h7).
    pose proof (sort_conv_inv IHu1) as e. subst. assumption.
  - specialize (IHu _ _ _ h0 h7).
    pose proof (heq_conv_inv IHu) as e. split_hyps.
    eapply conv_trans. 2: exact h11.
    apply cong_Eq ; assumption.
  - specialize (IHu _ _ _ h5 h11).
    pose proof (heq_conv_inv IHu) as e. split_hyps.
    eapply conv_trans ; [ | exact h13 ].
    apply cong_Heq ; assumption.
  - specialize (IHu1 _ _ _ h7 h16).
    specialize (IHu2 _ _ _ h8 h17).
    pose proof (heq_conv_inv IHu1) as e1.
    pose proof (heq_conv_inv IHu2) as e2. split_hyps.
    eapply conv_trans ; [ | exact h19 ].
    apply cong_Heq ; assumption.
  - specialize (IHu1 _ _ _ h4 h9).
    specialize (IHu2 _ _ _ h3 h8).
    pose proof (eq_conv_inv IHu1) as e1. split_hyps.
    eapply conv_trans ; [| exact h11 ].
    apply cong_Heq ; try assumption.
    + apply conv_refl.
    + apply cong_Transport ; try assumption.
      all: apply conv_refl.
  - specialize (IHu3 _ _ _ h0 h9).
    pose proof (heq_conv_inv IHu3) as e3. split_hyps.
    pose proof (sort_conv_inv H). subst.
    assert (hh : Σ ;;; Γ,, A1 |-i u1 : sSort z0).
    { eapply type_ctxconv ; try eassumption.
      - econstructor ; try eassumption.
        eapply typing_wf. eassumption.
      - constructor.
        + apply ctxconv_refl.
        + apply conv_sym. assumption.
    }
    specialize (IHu1 _ _ _ h5 hh).
    pose proof (sort_conv_inv IHu1). subst.
    eapply conv_trans ; [| exact h15 ].
    apply cong_Heq.
    + apply conv_refl.
    + apply cong_Prod ; try assumption.
      apply conv_refl.
    + apply conv_refl.
    + apply cong_Prod ; try assumption. apply conv_refl.
  - specialize (IHu5 _ _ _ h0 h12).
    pose proof (heq_conv_inv IHu5) as e5. split_hyps.
    pose proof (sort_conv_inv H). subst.
    eapply conv_trans ; [| exact h21 ].
    apply cong_Heq ; try assumption.
    + apply cong_Prod ; try assumption. apply conv_refl.
    + apply cong_Lambda ; try assumption. all: apply conv_refl.
    + apply cong_Prod ; try assumption. apply conv_refl.
    + apply cong_Lambda ; try assumption. all: apply conv_refl.
  - specialize (IHu3 _ _ _ h3 h16).
    specialize (IHu4 _ _ _ h0 h15).
    specialize (IHu6 _ _ _ h4 h17).
    pose proof (heq_conv_inv IHu3).
    pose proof (heq_conv_inv IHu4).
    pose proof (heq_conv_inv IHu6).
    split_hyps.
    eapply conv_trans ; [| exact h27 ].
    apply cong_Heq ; try assumption.
    + apply substs_conv. assumption.
    + apply cong_App ; try assumption. apply conv_refl.
    + apply substs_conv. assumption.
    + apply cong_App ; try assumption. apply conv_refl.
  - specialize (IHu3 _ _ _ h0 h9).
    pose proof (heq_conv_inv IHu3) as e3. split_hyps.
    pose proof (sort_conv_inv H). subst.
    assert (hh : Σ ;;; Γ,, A1 |-i u1 : sSort z0).
    { eapply type_ctxconv ; try eassumption.
      - econstructor ; try eassumption.
        eapply typing_wf. eassumption.
      - constructor.
        + apply ctxconv_refl.
        + apply conv_sym. assumption.
    }
    specialize (IHu1 _ _ _ h5 hh).
    pose proof (sort_conv_inv IHu1). subst.
    eapply conv_trans ; [| exact h15 ].
    apply cong_Heq.
    + apply conv_refl.
    + apply cong_Sum ; try assumption.
      apply conv_refl.
    + apply conv_refl.
    + apply cong_Sum ; try assumption. apply conv_refl.
  - specialize IHu3 with (1 := h0) (2 := h15).
    specialize IHu5 with (1 := h3) (2 := h16).
    specialize IHu6 with (1 := h4) (2 := h17).
    pose proof (heq_conv_inv IHu3).
    pose proof (heq_conv_inv IHu5).
    pose proof (heq_conv_inv IHu6).
    split_hyps.
    eapply conv_trans ; [| exact h27 ].
    apply cong_Heq.
    + apply cong_Sum ; try apply conv_refl. assumption.
    + apply cong_Pair ; try apply conv_refl ; assumption.
    + apply cong_Sum ; try apply conv_refl. assumption.
    + apply cong_Pair ; try apply conv_refl ; assumption.
  - specialize IHu3 with (1 := h0) (2 := h12).
    specialize IHu5 with (1 := h3) (2 := h13).
    pose proof (heq_conv_inv IHu3).
    pose proof (heq_conv_inv IHu5).
    split_hyps.
    eapply conv_trans ; [| exact h21 ].
    apply cong_Heq ; try assumption.
    + apply cong_Pi1 ; try assumption. apply conv_refl.
    + apply cong_Pi1 ; try assumption. apply conv_refl.
  - specialize IHu3 with (1 := h0) (2 := h12).
    specialize IHu5 with (1 := h3) (2 := h13).
    pose proof (heq_conv_inv IHu3).
    pose proof (heq_conv_inv IHu5).
    split_hyps.
    eapply conv_trans ; [| exact h21 ].
    apply cong_Heq ; try assumption.
    + apply substs_conv.
      apply cong_Pi1 ; try assumption. apply conv_refl.
    + apply cong_Pi2 ; try assumption. apply conv_refl.
    + apply substs_conv.
      apply cong_Pi1 ; try assumption. apply conv_refl.
    + apply cong_Pi2 ; try assumption. apply conv_refl.
  - specialize (IHu1 _ _ _ h0 h12).
    specialize (IHu2 _ _ _ h h10).
    specialize (IHu3 _ _ _ h3 h13).
    pose proof (heq_conv_inv IHu1).
    pose proof (heq_conv_inv IHu2).
    pose proof (heq_conv_inv IHu3).
    split_hyps. subst.
    pose proof (sort_conv_inv H). subst.
    eapply conv_trans ; [| exact h21 ].
    apply cong_Heq ; try apply conv_refl.
    + apply cong_Eq ; assumption.
    + apply cong_Eq ; assumption.
  - specialize (IHu1 _ _ _ h0 h9).
    specialize (IHu2 _ _ _ h h7).
    pose proof (heq_conv_inv IHu1).
    pose proof (heq_conv_inv IHu2).
    split_hyps.
    pose proof (sort_conv_inv H). subst.
    eapply conv_trans ; [| exact h15 ].
    apply cong_Heq.
    + apply cong_Eq ; assumption.
    + apply cong_Refl ; assumption.
    + apply cong_Eq ; assumption.
    + apply cong_Refl ; assumption.
  - specialize (IHu _ _ _ h0 h7).
    pose proof (eq_conv_inv IHu). split_hyps.
    eapply conv_trans ; [| exact h11 ].
    apply cong_Heq ; assumption.
  - specialize (IHu1 _ _ _ h h6).
    specialize (IHu3 _ _ _ h0 h8).
    apply conv_sym in IHu1. pose proof (sort_conv_inv IHu1). subst.
    pose proof (heq_conv_inv IHu3). split_hyps.
    eapply conv_trans ; [| exact h13 ].
    apply cong_Eq ; assumption.
  - specialize (IHu1 _ _ _ h0 h5).
    eapply conv_trans ; [| exact h7 ].
    assumption.
  - specialize (IHu _ _ _ h3 h7).
    pose proof (pack_conv_inv IHu).
    split_hyps.
    eapply conv_trans ; [| exact h9 ].
    assumption.
  - specialize (IHu _ _ _ h3 h7).
    pose proof (pack_conv_inv IHu).
    split_hyps.
    eapply conv_trans ; [| exact h9 ].
    assumption.
  - specialize (IHu _ _ _ h3 h7).
    pose proof (pack_conv_inv IHu).
    split_hyps.
    eapply conv_trans ; [| exact h9 ].
    apply cong_Heq ; try assumption ; apply conv_refl.
  - rewrite h4 in h0. inversion h0. subst. assumption.
Defined.

End Uniqueness.