Require Import FunctionalExtensionality.
Require Import List.
Require Import FJ_tactics.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import PNames.
Require Import EffPure.
Require Import EffExcept.
Require Import EffReader.

Section ESoundER.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.

  Variable E : Set -> Set -> Set.
  Context {Fun_F : forall A, Functor (E A)}.

  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.
  Context {Sub_StuckValue_V : StuckValue :<: V}.

  Context {eq_DType_DT : forall T, FAlgebra eq_DTypeName T (eq_DTypeR D) D}.
  Context {eq_DType_eq_DT : PAlgebra eq_DType_eqName D D (UP'_P (eq_DType_eq_P D))}.
  Context {eq_DType_neq_D : PAlgebra eq_DType_neqName D D (UP'_P (eq_DType_neq_P D))}.

  Variable MT : Set -> Set.
  Context {Fun_MT : Functor MT}.
  Context {Mon_MT : Monad MT}.
  Context {Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable (ME : Set -> Set). (* Evaluation Monad. *)
  Context {Fun_ME : Functor ME}.
  Context {Mon_ME : Monad ME}.
  Context {Environment_ME : Environment ME (list (Names.Value V))}.
  Context {Exception_ME : Exception ME Datatypes.unit}.
  Context {Fail_ME : FailMonad ME}.
  Context {Reasonable_ME : Reasonable_Monad ME}.

  Context {Typeof_E : forall T, FAlgebra TypeofName T (typeofR D MT) (E (DType D))}.
  Context {WF_MAlg_typeof : WF_MAlgebra Typeof_E}.

  Context {evalM_E : FAlgebra EvalName (Names.Exp (E nat)) (evalMR V ME) (E nat)}.

  Variable EQV_E : forall A B, (eqv_i E A B -> Prop) -> eqv_i E A B -> Prop.
  Context {funEQV_E : forall A B, iFunctor (EQV_E A B)}.

  Variable TypContext : Set.
  Context {TypContextCE : ConsExtensionC TypContext}.
  Context {GammaTypContext : GammaTypContextC D TypContext}.
  Context {TypContext_GCE : GammaConsExtensionC _ TypContext _ _}.

  Variable WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop.
  Context {funWFV : iFunctor WFV}.

  Context {WFV_Weaken_WFV : iPAlgebra WFValue_Weaken_Name (WFValue_Weaken_P D V _ WFV) WFV}.

  Variable WFVM : (WFValueM_i D V MT ME TypContext -> Prop) -> WFValueM_i D V MT ME TypContext -> Prop.
  Context {funWFVM : iFunctor WFVM}.
  Context {Sub_WFVM_Base_WFVM : Sub_iFunctor (WFValueM_base D V MT ME _ WFV) WFVM}.
  Context {Sub_WFVM_Except_WFVM : Sub_iFunctor (WFValueM_Except D V MT ME _) WFVM}.
  Context {Sub_WFVM_Environment_WFVM : Sub_iFunctor (WFValueM_Environment D MT V ME _ WFV) WFVM}.
  Context {Sub_WFVM_Bot_WFVM : Sub_iFunctor (WFValueM_Bot D V MT ME _) WFVM}.

  Context {EQV_proj1_EQV_E :
    forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P E EQV_E A B) (EQV_E _ _)}.
  Context {WFV_proj1_b_WFV : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV) WFV}.

  Variable WFV' : (WFValue_i D V (list (Names.DType D)) -> Prop) -> WFValue_i D V (list (Names.DType D)) -> Prop.
  Context {funWFV' : iFunctor WFV'}.
  Variable WFVM' : (WFValueM_i D V MT ME (list (Names.DType D)) -> Prop) ->
    WFValueM_i D V MT ME (list (Names.DType D)) -> Prop.
  Variable funWFVM' : iFunctor WFVM'.

  Definition Except_Sound_X_P (i : WFValueM_i D V MT ME _) :=
    forall T gamma''
      (WF_gamma'' : WF_Environment _ _ _ WFV' (wfvm_S _ _ _ _ _ i) gamma'' (wfvm_S _ _ _ _ _ i)),
      wfvm_T _ _ _ _ _ i = return_ T ->
      (local (fun _ => gamma'') (wfvm_v _ _ _ _ _ i) = fail) \/
      (exists t, local (fun _ => gamma'') (wfvm_v _ _ _ _ _ i) = throw t) \/
      exists v : Value V,
        local (fun _ => gamma'') (wfvm_v _ _ _ _ _ i) = return_ (M := ME) v /\
        WFValueC _ _ _ WFV' (wfvm_S _ _ _ _ _ i) v T.

  Context {WFV_proj1_b_WFV' : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV') WFV'}.

  Inductive Except_Sound_X_Name := except_sound_X_name.

  Global Instance Except_Sound_WFVM_base' :
    iPAlgebra Except_Sound_X_Name Except_Sound_X_P (WFValueM_base D V MT ME _ WFV').
  Proof.
    econstructor.
    unfold iAlgebra; intros; apply ind_alg_WFVM_base with (WFV := WFV')
      (Fail_MT := _) (Monad_ME := _);
      try assumption; unfold Except_Sound_X_P; intros; repeat right.
    (* WFVM_Return' *)
    simpl; rewrite local_return; exists v; repeat split; simpl in *; auto.
    destruct H1 as [mt' mt'_eq]; subst.
    destruct (MT_eq_dec _ mt') as [[s s_eq] | s_eq]; subst.
    rewrite fmap_return in H2.
    apply inj_return in H2; subst.
    simpl in *; subst; auto.
    destruct s as [T0 T0_UP']; simpl in *.
    destruct T0; apply (WFV_proj1_b D V _ WFV' _ _ H0); simpl; auto.
    failmonaddisc.
      (* WFVM_Untyped' *)
    simpl in H0; apply sym_eq in H0.
    elimtype False; eapply FailMonad_Disc with (M := MT) (a := T) (mb := mt); auto.
  Qed.

  Context {WFV_Weaken'_WFV : iPAlgebra WFValue_Weaken'_Name (WFValue_Weaken'_P _ _ _ WFV') WFV'}.

  Global Instance Except_Sound_X_WFVM_Environment :
    iPAlgebra Except_Sound_X_Name Except_Sound_X_P
    (WFValueM_Environment (TypContextCE := GammaTypContextCE D) D MT V ME _ WFV').
  Proof.
    econstructor.
    unfold iAlgebra; intros; apply ind_alg_WFVM_Environment with (MT := MT)
      (Fun_MT := Fun_MT) (Mon_MT := Mon_MT) (WFV := WFV')
      (TypContextCE := GammaTypContextCE D)
      (GammaTypContext := PNames.GammaTypContext D)
      (Environment_ME := Environment_ME); try eassumption;
        unfold Except_Sound_X_P; simpl; intros.
      (* WFVM_Local *)
    destruct (H0 gamma'' WF_gamma'' _ _ WF_gamma'' H1) as
      [eval_fail | [eval_throw | [v [eval_k WF_v_T0]]]].
    left; generalize ask_query; unfold wbind; intro ask_query'.
    rewrite local_bind, local_ask, ask_query', <- left_unit; auto.
    right; left; generalize ask_query; unfold wbind; intro ask_query'.
    rewrite local_bind, local_ask, ask_query', <- left_unit; auto.
    right; right; exists v; repeat split; auto.
    generalize ask_query; unfold wbind; intro ask_query'.
    rewrite local_bind, local_ask, ask_query', <- left_unit.
    apply eval_k; auto.
      (* WFVM_Ask *)
    rewrite local_bind, local_local; unfold Basics.compose.
    destruct (H1 _ _ (H0 _ WF_gamma'') (refl_equal _)) as
      [eval_fail | [[t eval_throw] | [v [eval_m WF_v_T0]]]].
    left; unfold DType, Value in *|-*; unfold wbind, Env in *|-*;
      rewrite eval_fail, bind_fail; auto.
    right; left; exists t; unfold DType, Value in *|-*; unfold wbind, Env in *|-*;
      rewrite eval_throw, bind_throw; auto.
    unfold DType, Value in *|-*; unfold wbind, Env in *|-*;
      rewrite eval_m, <- left_unit; destruct (H2 _ _ (refl_equal _)
        (WFV_Weaken' _ _ _ WFV' _ WF_v_T0 Sigma) _ _
        WF_gamma'' H3)
      as [eval_fail | [[t eval_throw] | [v' [eval_k WF_v'_T0]]]].
    auto.
    right; left; eexists _; eauto.
    repeat right; exists v'; repeat split; auto.
  Qed.

  Context {ME_eq_dec' : forall (A : Set) (mte : ME A) (env : list (Names.Value (Fun_V := Fun_V) V)),
    (exists a : A, local (fun _ => env) mte = return_ (Monad := Mon_ME) a) \/
    (local (fun _ => env) mte = fail) \/
    (local (fun _ => env) mte = throw tt)}.

  Variable local_throw : forall (A : Set) f t,
    local f (throw t) = throw t (A := A).
  Variable local_catch : forall (A : Set) e h f,
    local f (catch (A := A) e h) = catch (local f e) (fun t => local f (h t)).
  Variable catch_fail : forall (A : Set) h,
    catch (A := A) fail h = fail.
  Variable throw_neq_fail : forall (A : Set) t,
    throw t <> fail (A := A).

  Global Instance Except_Sound_X_WFVM_Except :
    iPAlgebra Except_Sound_X_Name Except_Sound_X_P
    (WFValueM_Except (TypContextCE := GammaTypContextCE D) D V MT ME _).
  Proof.
    econstructor.
    unfold iAlgebra; intros; apply ind_alg_WFVM_Except with (Fail_MT := Fail_MT)
      (TypContextCE := GammaTypContextCE D)
      (Exception_ME := Exception_ME) (eq_DType_DT := eq_DType_DT);
      try assumption; unfold Except_Sound_X_P; simpl; intros.
      (* throw case *)
    simpl; right; left; exists tt; apply local_throw.
    (* catch case *)
    destruct (MT_eq_dec _ mte) as [[T' mte_eq] | mte_eq]; subst.
    destruct (MT_eq_dec _ mth) as [[T'' mth_eq] | mth_eq]; subst.
    repeat rewrite <- left_unit in H2.
    caseEq (eq_DType _ (proj1_sig T') T''); rewrite H3 in H2.
    destruct (H0 _ _ WF_gamma'' H2) as
      [eval_fail | [[t eval_throw] | [v [eval_k WF_v_T0]]]].
    rewrite local_bind, local_catch.
    destruct (ME_eq_dec' _ e' gamma'') as [[v'' e'_eq] | [e'_eq | e'_eq]];
      unfold Env in *|-*; rewrite e'_eq in *|-*.
    left; rewrite catch_return, <- left_unit;
      rewrite local_bind, e'_eq, <- left_unit in eval_fail; auto.
    rewrite catch_fail, bind_fail; auto.
    rewrite local_bind, e'_eq, bind_throw in eval_fail;
      elimtype False; eapply throw_neq_fail; eauto.
    rewrite local_bind, local_catch.
    destruct (ME_eq_dec' _ e' gamma'') as [[v'' e'_eq] | [e'_eq | e'_eq]];
      unfold Env in *|-*; rewrite e'_eq in *|-*.
    right; left; rewrite catch_return, <- left_unit;
      rewrite local_bind, e'_eq, <- left_unit in eval_throw; eauto.
    rewrite local_bind, e'_eq, bind_fail in eval_throw;
      elimtype False; eapply throw_neq_fail; eauto.
    rewrite catch_throw', <- local_bind.
    destruct (MT_eq_dec _ kT') as [[c kT'_eq] | kT'_eq]; subst.
    repeat rewrite <- left_unit in H1, H2.
    destruct (MT_eq_dec _ (kT c T'')) as [[d kTcT''_eq] | kTcT''_eq].
    destruct (H1 tt _ (refl_equal _) _ _ WF_gamma'' kTcT''_eq) as
      [eval_fail | [[t' eval_throw'] | [v [eval_k WF_v_T0]]]];
      eauto.
    repeat right; exists v; repeat split; eauto.
    destruct T; apply (WFV_proj1_b D V _ WFV' _ _ WF_v_T0); simpl; auto.
    generalize (kt_eq _ _ (eq_DType_eq _ _ _ H3)).
      repeat rewrite <- left_unit;
      rewrite H2, kTcT''_eq; simpl;
      repeat rewrite fmap_return;
      intros x_eq; apply inj_return in x_eq; auto.
    elimtype False; generalize (kt_eq _ _ (eq_DType_eq _ _ _ H3));
      repeat rewrite <- left_unit; rewrite H2, kTcT''_eq; simpl;
      rewrite fmap_return; rewrite fmap_fail; intros x_eq.
    failmonaddisc.
    failmonaddisc.
    rewrite local_bind, local_catch.
    destruct (ME_eq_dec' _ e' gamma'') as [[v'' e'_eq] | [e'_eq | e'_eq]];
      unfold Env in *|-*; rewrite e'_eq in *|-*.
    repeat right; rewrite catch_return, <- left_unit;
      rewrite local_bind, e'_eq, <- left_unit in eval_k; eauto.
    rewrite catch_fail, bind_fail; auto.
    rewrite local_bind, e'_eq, bind_throw in eval_k.
    elimtype False; eapply Exception_Disc with (M := ME) (a := v) (mb := return_ tt);
    eauto; unfold wbind; rewrite <- left_unit; eauto.
    destruct (MT_eq_dec _ kT') as [[c kT'_eq] | kT'_eq]; subst; failmonaddisc.
    destruct (MT_eq_dec _ kT') as [[c kT'_eq] | kT'_eq]; subst; failmonaddisc.
    destruct (MT_eq_dec _ kT') as [[c kT'_eq] | kT'_eq]; subst; failmonaddisc.
  Qed.

  Context {FailEnvM : FailEnvironmentMonad (Env (Value V)) ME}.

  Global Instance Except_Sound_X_WFVM_Bot :
    iPAlgebra Except_Sound_X_Name Except_Sound_X_P (WFValueM_Bot D V MT ME _).
  Proof.
    econstructor.
    unfold iAlgebra; intros; eapply ind_alg_WFVM_Bot;
      try eassumption; unfold Except_Sound_X_P; simpl; intros.
    (* WFVM_fail *)
    left; rewrite local_fail; auto.
  Qed.

  Context {soundness_X'_alg :
    forall eval_rec,
      iPAlgebra soundness_X'_Name
      (soundness_X'_P D V E MT ME _ EQV_E WFVM' (fun e => typeof _ _ MT (proj1_sig e)) eval_rec
        (f_algebra (FAlgebra := Typeof_E _))
        (f_algebra (FAlgebra := evalM_E))) (EQV_E _ _)}.
  Context {Except_Sound_X_WFVM : iPAlgebra Except_Sound_X_Name Except_Sound_X_P WFVM'}.

  Context {Sub_WFVM_Bot_WFVM' : Sub_iFunctor (WFValueM_Bot _ _ _ _ (list (DType D))) WFVM'}.

  Theorem Except_Sound_X :
    forall (n : nat) Sigma gamma gamma' gamma'' e' e'',
      E_eqvC E EQV_E gamma' gamma e'' e' ->
      forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
        exists T, lookup gamma b = Some T)
      (WF_gamma'' : WF_Environment _ _ _ WFV' Sigma gamma'' gamma)
      (WF_gamma2 : List.length gamma = List.length gamma')
      (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
      (WF_Sigma : Gamma D Sigma = gamma) (T : DType D),
      typeof D (E (DType D)) MT (Typeof_E := Typeof_E) (proj1_sig e') = return_ T ->
      (local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = fail) \/
      (exists t, local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = throw t) \/
        exists v : Value V,
          local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') =
          return_ (M := ME) v /\ WFValueC _ _ _ WFV' Sigma v T.
  Proof.
    intros.
    intros; eapply (ifold_ WFVM' _ (ip_algebra (iPAlgebra := Except_Sound_X_WFVM))
      _ (eval_soundness_X' D V E MT ME _ EQV_E WFVM' n _ _ _ _ H Sigma WF_gamma WF_gamma2 WF_gamma' WF_Sigma));
    simpl in *|-*; unfold DType in *|-*; eauto;
    simpl in H0; eauto.
    unfold id in *|-*; subst; eauto.
  Qed.

End ESoundER.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import SimrelDefinition.
Require Import SimrelCategory.
Require Import AbstractDataType.
Require SimrelInvariant.

(** This module originated as a variant of [SimrelInvariant] to account for the
  fact that primitives should preserve the kernel mode flag of the abstract
  data. *)

(** ** Invariants *)

Section KERNELMODE.
  Context `{Hmem: BaseMemoryModel}.

  (** *** Definition *)

  Definition km_world :=
    unit.
    (* sig (fun x => forall b, block_is_global b -> Pos.lt b x). *)

  Definition kernel_mode (D: certikosdata) (d: D) :=
    ikern d = true /\ ihost d = true.

  Program Definition km_ops (D: certikosdata): simrel_components D D :=
    {|
      simrel_world := km_world;
      simrel_acc := {| le := fun _ _ => True |};
      simrel_new_glbl := nil;
      simrel_undef_matches_values_bool := false;
      simrel_undef_matches_block p b := False;
      match_mem w m m' := m = m' /\ kernel_mode D (snd m);
      simrel_meminj w := inject_id
    |}.

  (** *** Properties *)

  Global Instance match_mem_corefl D p:
    Coreflexive (match_mem (km_ops D) p).
  Proof.
    intros m m' H.
    destruct H.
    assumption.
  Qed.

  Global Instance match_val_km_refl D p:
    Reflexive (match_val (km_ops D) p).
  Proof.
    red. intro v; subst.
    destruct v; try constructor.
    replace i with (Ptrofs.add i Ptrofs.zero) at 2 by apply Ptrofs.add_zero.
    econstructor; eauto.
  Qed.

  Global Instance match_val_km_corefl D p:
    Coreflexive (match_val (km_ops D) p).
  Proof.
    intros v1 v2 Hv.
    destruct Hv; try constructor; try now (discriminate H || destruct H).
    inv H. simpl in H1. unfold inject_id in H1.
    inv H1. rewrite Ptrofs.add_zero. reflexivity.
  Qed.

  Global Instance match_ptr_km_corefl D p:
    Coreflexive (match_ptr (km_ops D) p).
  Proof.
    intros v1 v2 Hv.
    destruct Hv; try constructor; try now (discriminate H || destruct H).
    inv H. rewrite Z.add_0_r. reflexivity.
  Qed.

  Global Instance match_ptrbits_km_corefl D p:
    Coreflexive (match_ptrbits (km_ops D) p).
  Proof.
    intros v1 v2 Hv.
    destruct Hv. simpl in H.
    unfold inject_id in H. inv H.
    rewrite Ptrofs.add_zero. reflexivity.
  Qed.

  Global Instance match_ptrrange_km_corefl D p:
    Coreflexive (match_ptrrange (km_ops D) p).
  Proof.
    intros v1 v2 Hv.
    destruct Hv.
    apply coreflexivity in H. inv H. reflexivity.
  Qed.

  Global Instance match_block_km_corefl D p:
    Coreflexive (match_block (km_ops D) p).
  Proof.
    intros v1 v2 Hv.
    destruct Hv. simpl in H.
    unfold inject_id in H. inv H.
    reflexivity.
  Qed.

  Global Instance match_vals_km_corefl D p:
    Coreflexive (list_rel (match_val (km_ops D) p)).
  Proof.
    intros vs1 vs2 Hvs.
    induction Hvs; try constructor.
    f_equal; eauto.
    eapply match_val_km_corefl; eauto.
  Qed.

  Global Instance match_memval_km_corefl D p:
    Coreflexive (match_memval (km_ops D) p).
  Proof.
    intros v1 v2 Hv.
    destruct Hv; try constructor; try now (discriminate H || destruct H).
    f_equal; rauto.
  Qed.

  Global Instance match_memval_km_refl D p:
    Reflexive (match_memval (km_ops D) p).
  Proof.
    red. intro v; subst.
    destruct v; try constructor.
    reflexivity.
  Qed.

  Global Instance match_memvals_km_refl D p:
    Reflexive (list_rel (match_memval (km_ops D) p)).
  Proof.
    red.
    induction x; simpl; intros; constructor; reflexivity.
  Qed.

  Global Instance match_memvals_km_corefl D p:
    Coreflexive (list_rel (match_memval (km_ops D) p)).
  Proof.
    intros vs1 vs2 Hvs.
    induction Hvs; try constructor.
    f_equal; eauto.
    eapply match_memval_km_corefl; eauto.
  Qed.

  Lemma km_inject_neutral_match_val D p v :
    Val.inject inject_id v v <->
    match_val (km_ops D) p v v.
  Proof.
    split; intros Hv;
    inversion Hv; clear Hv; try constructor.
    {
      pattern ofs1 at 2.
      rewrite H3.
      constructor.
      assumption.
    }
    subst.
    inversion H1.
    rewrite H4 at 1.
    econstructor; eauto.
  Qed.

  Lemma km_inject_neutral_match_vals D p l:
    Val.inject_list inject_id l l <->
    list_rel (match_val (km_ops D) p) l l .
  Proof.
    split; intros Hl; induction l; inversion Hl; subst; constructor; auto.
    + rewrite <- km_inject_neutral_match_val. simpl. assumption.
    + rewrite <- km_inject_neutral_match_val in *. simpl in *. assumption.
  Qed.

  Lemma km_inject_neutral_match_memval D p v:
    memval_inject inject_id v v <->
    match_memval (km_ops D) p v v.
  Proof.
    split; intros Hv;
    inversion Hv; clear Hv; try constructor.
    - apply km_inject_neutral_match_val.
      assumption.
    - apply km_inject_neutral_match_val in H1.
      assumption.
  Qed.

  Lemma km_inject_neutral_match_memvals D p vs:
    list_forall2 (memval_inject inject_id) vs vs <->
    list_rel (match_memval (km_ops D) p) vs vs.
  Proof.
    generalize (eq_refl vs).
    generalize vs at 2 4 6.
    revert vs.
    intros vs1 vs2 Hvseq.
    split.
    {
      intro Hvs.
      revert Hvseq.
      induction Hvs.
      - constructor.
      - intros Heq.
        constructor.
        + inversion Heq.
          eapply km_inject_neutral_match_memval.
          congruence.
        + eapply IHHvs.
          congruence.
    }
    intro Hvs.
    revert Hvseq.
    induction Hvs.
    - constructor.
    - intros Heq.
      constructor.
      + inversion Heq.
        rewrite km_inject_neutral_match_memval with (D := D) (p:=p).
        congruence.
      + eapply IHHvs.
        congruence.
  Qed.

  Lemma km_match_val_inject_neutral D p v1 v2:
    match_val (km_ops D) p v1 v2 ->
    Val.inject inject_id v1 v2.
  Proof.
    intros Hv.
    inversion Hv; subst; try now constructor.
    inversion H; subst.
    econstructor; eauto.
  Qed.

  Lemma km_match_memval_inject_neutral D p v1 v2:
    match_memval (km_ops D) p v1 v2 ->
    memval_inject inject_id v1 v2.
  Proof.
    intros Hv.
    inversion Hv; subst; constructor.
    eapply km_match_val_inject_neutral; eauto.
  Qed.

  Lemma km_match_memvals_inject_neutral D p v1 v2:
    list_rel (match_memval (km_ops D) p) v1 v2 ->
    list_forall2 (memval_inject inject_id) v1 v2.
  Proof.
    intros Hv.
    induction Hv; constructor; eauto.
    eapply km_match_memval_inject_neutral; eauto.
  Qed.

  (** *** Initial states *)

  (** To prove that initial memories satisfy the invariant, we first
    characterize the construction of initial memories with abstract
    data. *)

(*  Section WITHDATA.
    Context {D: layerdata}.

    Lemma store_zeros_with_data:
      forall m b o n (d: D),
        store_zeros (m, d) b o n =
        match store_zeros m b o n with
          | Some m' => Some (m', d)
          | None => None
        end.
    Proof.
      intros.
      functional induction (store_zeros m b o n); intros.
      * rewrite store_zeros_equation.
        rewrite e.
        reflexivity.
      * rewrite <- IHo0; clear IHo0.
        rewrite store_zeros_equation.
        rewrite e.
        lift_unfold.
        rewrite e0.
        reflexivity.
      * rewrite store_zeros_equation.
        rewrite e.
        lift_unfold.
        rewrite e0.
        reflexivity.
    Qed.

    Lemma store_init_data_with_data:
      forall {F V: Type} (ge: _ F V) m b p a (d: D),
        Genv.store_init_data ge (m, d) b p a =
        match Genv.store_init_data ge m b p a with
          | Some m' => Some (m', d)
          | None => None
        end.
    Proof.
      intros.
      destruct a; simpl; try reflexivity.
      destruct (Genv.find_symbol ge i); reflexivity.
    Qed.

    Lemma store_init_data_list_with_data:
      forall {F V: Type} (ge: _ F V) l m b p (d: D),
        Genv.store_init_data_list ge (m, d) b p l =
        match Genv.store_init_data_list ge m b p l with
          | Some m' => Some (m', d)
          | None => None
        end.
    Proof.
      induction l; simpl; try reflexivity.
      intros.
      rewrite store_init_data_with_data.
      destruct (Genv.store_init_data ge m b p a); try reflexivity.
      eauto.
    Qed.

    Lemma alloc_global_with_data:
      forall {F V} (ge: _ F V),
        forall m ig (d: D),
          Genv.alloc_global ge (m, d) ig =
          match Genv.alloc_global ge m ig with
            | Some m' => Some (m', d)
            | None => None
          end.
    Proof.
      unfold Genv.alloc_global. intros.
      destruct ig as [? [ [ | ] | ]].
      * (* function *)
        lift_unfold.
        destruct (Mem.alloc m 0 1).
        reflexivity.
      * (* variable *)
        lift_unfold.
        destruct (Mem.alloc m 0 (init_data_list_size (gvar_init v))).
        unfold set; simpl.
        rewrite store_zeros_with_data.
        destruct (store_zeros m0 b 0 (init_data_list_size (gvar_init v))); try reflexivity.
        rewrite store_init_data_list_with_data.
        destruct (Genv.store_init_data_list ge m1 b 0 (gvar_init v)); reflexivity.
      * (* none *)
        lift_unfold.
        destruct (Mem.alloc m 0 0); reflexivity.
    Qed.

    Lemma alloc_globals_with_data:
      forall {F V} (ge: _ F V),
        forall l m (d: D),
          Genv.alloc_globals ge (m, d) l =
          match Genv.alloc_globals ge m l with
            | Some m' => Some (m', d)
            | None => None
          end.
    Proof.
      induction l; simpl; try reflexivity.
      intros.
      rewrite alloc_global_with_data.
      destruct (Genv.alloc_global ge m a); try reflexivity.
      eauto.
    Qed.

    Theorem init_mem_with_data:
      forall {F V} (p: _ F V),
        Genv.init_mem (mem := mwd D) p =
        match Genv.init_mem (mem := mem) p with
          | Some m' => Some (m', init_data)
          | None => None
        end.
    Proof.
      intros.
      unfold Genv.init_mem.
      simpl.
      apply alloc_globals_with_data.
    Qed.
  End WITHDATA.
 *)

(** XXX: mettre au bon endroit. *)
Instance:
  Related Pos.lt Pos.le subrel.
Proof.
  intros x y Hxy.
  apply Pos.le_lteq.
  eauto.
Qed.

Ltac coreflexivity H :=
  let Heq := fresh in
  pose proof (coreflexivity _ _ H) as Heq; inv Heq.

  Global Instance km_prf D:
    SimulationRelation (km_ops D).
  Proof.
    split.
    - (* carrier preorder *)
      split; simpl; eauto.
    - (* simrel_undef_matches_block increases with carrier *)
      simpl. solve_monotonic.
    - (* match_block increases with carrier *)
      simpl; unfold RelCompFun.
      intros p1 p2 Hp.
      red.
      intro b.
      unfold inject_id. repeat constructor.
    - (* undef_matches_values implies undef_matches_block *)
      discriminate.
    - (* undef_matches_block implies undef_matches_values *)
      simpl; tauto.
    - (* undef_match_block for non-injective match_block *)
      simpl.
      intros.
      coreflexivity H0.
      coreflexivity H1.
      congruence.
    - (* undef_match_block for non weakly valid pointers *)
      intros.
      coreflexivity H1.
      coreflexivity H.
      revert H0 H2; simpl.
      unfold Mem.weak_valid_pointer; simpl.
      lift_unfold.
      congruence.
    - (* undef_match_block for invalid pointers *)
      intros.
      coreflexivity H1.
      coreflexivity H.
      revert H0 H2; simpl.
      unfold Mem.weak_valid_pointer; simpl.
      lift_unfold.
      congruence.

    - (* global blocks related to themselves *)
      intros p b Hb.
      destruct p as [thr Hthr].
      red.
      unfold match_block_sameofs.
      simpl.
      unfold inject_id.
      auto.

    - (* global blocks related to themselves, reciprocal *)
      intros p b1 b2 Hb2 [delta Hinj].
      simpl in Hinj.
      unfold inject_id in Hinj.
      congruence.

    - (* [Genv.init_mem] *)
      intros.
      intros p1 p2 Hp.
      assert
        ((option_le ((rexists w, match_mem (simrel_id (D:=D)) w) /\
                     (req glob_threshold @@ Mem.nextblock)))
           (Genv.init_mem p1)
           (Genv.init_mem p2)) as Hm.
      {
        eapply genv_init_mem_simrel_withnextblock; eauto.
        + apply SimrelCategory.simrel_id_init_mem.
        + intros x y [H _].
          exists tt.
          assumption.
      }
      pose proof (@SimrelInvariant.init_mem_with_data _ D F1 V p1).
      destruct (Genv.init_mem (mem:=mwd D) p1) as [m1|] eqn:Hinit_mem; [|constructor].
      destruct (Genv.init_mem (mem:=mem) p1) as [m|] eqn:Hm1'; try discriminate.
      inversion Hm as [ | xm1 xm2 Hmeq]; clear Hm; subst.
      constructor.
      destruct Hmeq as [[[] Hmeq] Hmnb].
      simpl in Hmeq; subst.
      inversion H; clear H; subst.
      assert (Hw: forall b, block_is_global b -> (b < Mem.nextblock m)%positive).
      {
        intros b Hb.
        red in Hmnb.
        lift_unfold.
        destruct Hmnb.
        exact Hb.
      }
      exists tt.
      split; auto.
      simpl.
      red; split; reflexivity.

    - (* [Mem.alloc] *)
      intros p m m1 Hm ofs sz.
      coreflexivity Hm.
      exists tt; split; auto.
      + simpl; auto.
      + split; [ constructor | ] ; simpl.
        * lift_unfold.
          destruct Hm; subst.
          f_equal.
        * lift_unfold. destruct Hm; subst.
          destruct @Mem.alloc. simpl. auto.
        * lift_unfold.
          destruct Hm; subst.
          destruct @Mem.alloc. simpl. auto.
          unfold match_block_sameofs.
          simpl.
          unfold inject_id.
          congruence.

    - (* [Mem.free] *)
      intros p m1 m2 Hm [[b1 lo1] hi1] [[b2 lo2] hi2] Hb.
      coreflexivity Hm.
      coreflexivity Hb.
      simpl in *.
      lift_unfold.
      destruct (Mem.free _ _ _ _) as [m'|] eqn:Hm'; constructor.
      exists tt.
      split; auto.
      split; auto.
      lift_simpl. intuition.

    - (* [Mem.load] *)
      intros p chunk m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb.
      coreflexivity Hm.
      coreflexivity Hb.
      simpl in *.
      lift_unfold.
      destruct (@Mem.load) as [v|] eqn:Hv; constructor.
      reflexivity.

    - (* [Mem.store] *)
      intros p chunk m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb v1 v2 Hv.
      coreflexivity Hb.
      coreflexivity Hv.
      coreflexivity Hm.
      destruct (uncurry _ _ _) eqn:?; constructor.
      exists tt; simpl; split; auto.
      split; auto.
      simpl in Hm; intuition.
      unfold uncurry in Heqy.
      lift_unfold. intuition congruence.

    - (* [Mem.loadbytes] *)
      intros p m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb len.
      coreflexivity Hm.
      coreflexivity Hb.
      simpl in *.
      lift_unfold.
      destruct (Mem.loadbytes _ _ _ _) as [v|] eqn:Hv; constructor.
      reflexivity.

    - (* [Mem.storebytes] *)
      intros p m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb vs1 vs2 Hvs.
      coreflexivity Hm.
      coreflexivity Hb.
      coreflexivity Hvs.
      simpl in *.
      lift_unfold.
      destruct (Mem.storebytes _ _ _ _) as [m'|] eqn:Hm'; constructor.
      split; split; split; eauto.
      lift_simpl. intuition.

    - (* [Mem.perm] *)
      intros p m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb k perm.
      coreflexivity Hm.
      coreflexivity Hb.
      reflexivity.

    - (* [Mem.valid_block] *)
      intros p m1 m2 Hm b1 b2 Hb.
      coreflexivity Hm.
      coreflexivity Hb.
      simpl in *.
      unfold Mem.valid_block. simpl. lift_unfold.
      tauto.

    - (* [Mem.different_pointers_inject] *)
      intros p m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2 H H0 H1 H2 H3 H4.
      simpl in H3, H4.
      unfold inject_id in H3, H4.
      inv H3. inv H4.
      tauto.

    - (* [Mem.weak_valid_pointer_inject_val] *)
      intros.
      coreflexivity H.
      coreflexivity H1.
      assumption.

    - (* weak_valid_pointer_address_inject_weak *)
      intros p m1 m2 b1 b2 delta H H0.
      coreflexivity H.
      simpl in H0.
      unfold inject_id in H0.
      inv H0.
      exists 0.
      intros ofs1 WVP.
      rewrite Ptrofs.add_zero.
      omega.

    - (* [Mem.address_inject] *)
      intros p m1 m2 b1 ofs1 b2 delta pe H H0 H1.
      simpl in H1.
      unfold inject_id in H1.
      inv H1.
      rewrite Ptrofs.add_zero.
      omega.

    - (* [Mem.aligned_area_inject] *)
      intros p m m' b ofs al sz b' delta H H0 H1 H2 H3 H4 H5.
      simpl in H5.
      unfold inject_id in H5.
      inv H5.
      rewrite Z.add_0_r.
      assumption.

    - (* [Mem.disjoint_or_equal_inject] *)
      intros p m m' b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 sz H H0 H1 H2 H3 H4 H5.
      simpl in H0, H1.
      unfold inject_id in H0, H1.
      inv H0; inv H1.
      intuition omega.
  Qed.

  Definition km {D: certikosdata}: simrel D D :=
    {|
      simrel_ops := km_ops D
    |}.
End KERNELMODE.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.

Inductive insn :=
| Block (code : list insn)
| Arg
| Self
| Deref (off : nat)
| Call
| MkConstr (tag : nat) (nargs : nat)
| Switch (cases : list (list insn))
| MkClose (f : function_name) (nfree : nat)
| OpaqueOp (op : opaque_oper_name) (nargs : nat)
.

Definition env := list (list insn).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    stack : list value
}.

Definition push f v :=
    Frame (arg f) (self f) (v :: stack f).

Definition pop f n :=
    Frame (arg f) (self f) (skipn n (stack f)).

Definition pop_push f n v :=
    push (pop f n) v.

Definition top f :=
    match stack f with
    | [] => Constr 0 []
    | v :: _ => v
    end.

Inductive cont :=
| Ktail (code : list insn) (stk : list value) (k : cont)
| Kret (code : list insn) (f : frame) (k : cont)
(* keeping the original `stk` lets us enforce that each branch pushes
 * exactly one value before running SContSwitch *)
| Kswitch (code : list insn) (stk : list value) (k : cont)
| Kstop.

Inductive state :=
| Run (i : list insn) (f : frame) (k : cont)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SBlock : forall code is f k,
        sstep E (Run (Block code :: is) f k)
                (Run code (Frame (arg f) (self f) []) (Ktail is (stack f) k))

| SArg : forall f k,
        stack f = [] ->
        sstep E (Run [Arg] f k)
                (Run [] (push f (arg f)) k)
| SSelf : forall f k,
        stack f = [] ->
        sstep E (Run [Self] f k)
                (Run [] (push f (self f)) k)

| SDerefinateConstr : forall off f k  tag args v,
        stack f = [Constr tag args] ->
        nth_error args off = Some v ->
        sstep E (Run [Deref off] f k)
                (Run [] (pop_push f 1 v) k)
| SDerefinateClose : forall off f k  fname free v,
        stack f = [Close fname free] ->
        nth_error free off = Some v ->
        sstep E (Run [Deref off] f k)
                (Run [] (pop_push f 1 v) k)

| SConstrDone : forall tag nargs f k,
        length (stack f) = nargs ->
        sstep E (Run [MkConstr tag nargs] f k)
                (Run [] (pop_push f nargs (Constr tag (rev (stack f)))) k)
| SCloseDone : forall fname nfree f k,
        length (stack f) = nfree ->
        sstep E (Run [MkClose fname nfree] f k)
                (Run [] (pop_push f nfree (Close fname (rev (stack f)))) k)
| SOpaqueOpDone : forall op nargs f k v,
        length (stack f) = nargs ->
        opaque_oper_denote_higher op (rev (stack f)) = Some v ->
        sstep E (Run [OpaqueOp op nargs] f k)
                (Run [] (pop_push f nargs v) k)

| SMakeCall : forall f k  fname free body argv,
        stack f = [argv; Close fname free] ->
        nth_error E fname = Some body ->
        sstep E (Run [Call] f k)
                (Run body (Frame argv (Close fname free) [])
                    (Kret [] (pop f 2) k))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall cases f k  tag args case,
        stack f = [] ->
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run [Switch cases] f k)
                (Run case f (Kswitch [] (stack f) k))

| SContTail : forall code f stk k v,
        stack f = [v] ->
        sstep E (Run [] f (Ktail code stk k))
                (Run code (Frame (arg f) (self f) (v :: stk)) k)
| SContRet : forall code f f' k v,
        stack f = [v] ->
        sstep E (Run [] f (Kret code f' k))
                (Run code (push f' v) k)
| SContSwitch : forall code f stk k v,
        stack f = v :: stk ->
        sstep E (Run [] f (Kswitch code stk k))
                (Run code f k)
| SContStop : forall f v,
        stack f = [v] ->
        sstep E (Run [] f Kstop)
                (Stop v)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 Kstop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition insn_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HBlock :   forall code, Pl code -> P (Block code))
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (i : insn) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        let fix go_list_list iss :=
            match iss as iss_ return Pll iss_ with
            | [] => Hnil2
            | is :: iss => Hcons2 is iss (go_list is) (go_list_list iss)
            end in
        match i as i_ return P i_ with
        | Block code => HBlock code (go_list code)
        | Arg => HArg
        | Self => HSelf
        | Deref off => HDeref off
        | Call => HCall
        | MkConstr tag nargs => HConstr tag nargs
        | Switch cases => HSwitch cases (go_list_list cases)
        | MkClose fname nfree => HClose fname nfree
        | OpaqueOp op nargs => HOpaqueOp op nargs
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition insn_ind' (P : insn -> Prop)
    (HBlock :   forall code, Forall P code -> P (Block code))
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Forall (Forall P) cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (i : insn) : P i :=
    ltac:(refine (@insn_rect_mut P (Forall P) (Forall (Forall P))
        HBlock HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp _ _ _ _ i); eauto).

Definition insn_list_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HBlock :   forall code, Pl code -> P (Block code))
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (is : list insn) : Pl is :=
    let go := insn_rect_mut P Pl Pll
            HBlock HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp
            Hnil Hcons Hnil2 Hcons2 in
    let fix go_list is :=
        match is as is_ return Pl is_ with
        | [] => Hnil
        | i :: is => Hcons i is (go i) (go_list is)
        end in go_list is.


(** CompCert transform_program* and LayerLib make_program. *)

Require Import compcert.lib.Coqlib.
Require Import compcert.common.Values.
Require Import compcert.common.AST.
Require Export liblayers.logic.Structures.
Require Export liblayers.logic.OptionOrders.
Require Export liblayers.lib.OptionMonad.
Require Export liblayers.compcertx.ErrorMonad.
Require Import Coq.Classes.RelationPairs.
Require Export liblayers.compcertx.CompcertStructures.
Require Import liblayers.compcertx.MakeProgramSpec.
Require Import liblayers.logic.GlobalVars.

Arguments mkglobvar {_} _ _ _ _.

Inductive globvar_rel
          {V_prog_from V_prog_to: Type} (R: rel V_prog_from V_prog_to):
  rel (globvar V_prog_from) (globvar V_prog_to)
  :=
    globvar_rel_intro:
      Monotonic
        mkglobvar
        (R ++> eq ++> eq ++> eq ++> globvar_rel R).

(* transform_program and program_rel *)

Section TRANSFORM_PROGRAM.

  Local Existing Instance globvar_rel_intro.

  Context {F_prog_from V_prog_from F_prog_to V_prog_to: Type}.

  Variables transf_F_prog: F_prog_from -> res F_prog_to.
  Variables transf_V_prog: V_prog_from -> res V_prog_to.

  Let RF_prog := fun _: ident => option_rel (fun f_from f_to => transf_F_prog f_from = OK f_to).
  Let RV_prog := fun _: ident => option_rel (globvar_rel (fun v_from v_to => transf_V_prog v_from = OK v_to)).

  Section GLOBDEFS_REL.

  Let globdefs_rel := list_rel ((eq (A := ident)) * rforall i, globdef_rel (RF_prog) (RV_prog) i)%rel.

  Lemma transf_globdefs_rel_recip l_from l_to:
      globdefs_rel l_from l_to ->
      transf_globdefs (fun _ => transf_F_prog) (fun _ => transf_V_prog) l_from = OK l_to.
  Proof.
    induction 1; simpl; auto.
    inversion_clear H; subst.
    destruct x; destruct y; simpl in * |- * ; subst.
    specialize (H2 i0).
    inversion_clear H2; subst.
    rewrite IHlist_rel; clear IHlist_rel; simpl.
    unfold Monad.bind in *;
    destruct o; destruct o0; simpl in * |- * ; auto.
    {
      destruct g; destruct g0; (try now inversion H); (try now inversion H1);
      unfold fun_of_globdef, var_of_globdef in *;
      simpl in *.
      {
        inversion_clear H; subst.
        rewrite H2.
        reflexivity.
      }
      inversion_clear H1; subst.
      inversion_clear H2; subst.
      unfold transf_globvar; simpl.
      unfold bind; simpl.
      rewrite H1.
      reflexivity.
    }
    {
      destruct g; (try now inversion H); (try now inversion H1).
    }
    destruct g; (try now inversion H); (try now inversion H1).
  Qed.

  Lemma globdefs_rel_flip_impl:
    forall j,
      subrel
        (CompcertStructures.globdefs_rel (fun i => flip (RF_prog i)) (fun i => flip (RV_prog i)) j)
        (flip globdefs_rel).
  Proof.
    unfold flip, globdefs_rel.
    red.
    induction 1.
    { constructor. }
    apply app_rel; auto.
    constructor.
    {
      constructor; auto.
      red.
      intros c.
      inversion H0.
      constructor; auto.
    }
    constructor.
  Qed.

  End GLOBDEFS_REL.

  Lemma transform_partial_program2_recip_flip p:
    forall pto,
      program_rel (fun j => flip (RF_prog j)) (fun j => flip (RV_prog j)) pto p ->
      transform_partial_program2 (fun _ => transf_F_prog) (fun _ => transf_V_prog) p = OK pto.
  Proof.
    intros pto H.
    inversion H; subst.
    inversion program_rel_upto_glob_threshold; subst.
    unfold transform_partial_program2.
    simpl.
    apply globdefs_rel_flip_impl in H0.
    apply transf_globdefs_rel_recip in H0.
    rewrite H0.
    reflexivity.
  Qed.

  Context
    {ld_from Fm_from Vm_from module_from : Type}
    {primsem_from layer_from : ld_from -> Type}
    {gvar_from_ops: GlobalVarsOps (globvar Vm_from)}
    {module_from_ops : ModuleOps ident Fm_from (globvar Vm_from) module_from}
    {primsem_from_ops : PrimitiveOps primsem_from}
    {layer_from_ops : LayerOps ident primsem_from (globvar Vm_from) layer_from}
    {program_format_ops_from: ProgramFormatOps Fm_from Vm_from F_prog_from V_prog_from}
    {D_from: ld_from}
  .

  Context
    {ld_to Fm_to Vm_to module_to : Type}
    {primsem_to layer_to : ld_to -> Type}
    {gvar_to_ops: GlobalVarsOps (globvar Vm_to)}
    {module_to_ops : ModuleOps ident Fm_to (globvar Vm_to) module_to}
    {primsem_to_ops : PrimitiveOps primsem_to}
    {layer_to_ops : LayerOps ident primsem_to (globvar Vm_to) layer_to}
    {program_format_ops_to: ProgramFormatOps Fm_to Vm_to F_prog_to V_prog_to}
    {D_to: ld_to}
  .

  Variables
    (convert_primsem: ident -> primsem_from D_from -> primsem_to D_to)
    (convert_globalvar: Vm_from -> Vm_to)
  .

  (* Source to compiled. *)

  Let RF_module: funrel D_from D_to :=
    fun i =>
    option_rel
      ((fun (f_from: Fm_from) f_to =>
         exists fp_from,
           make_internal f_from = OK fp_from /\
           exists fp_to,
             transf_F_prog fp_from = OK fp_to /\
             make_internal f_to = OK fp_to) + (fun p_from p_to => convert_primsem i p_from = p_to)).

  Let RV_module: varrel (Vm1 := Vm_from) (Vm2 := Vm_to) :=
    fun _ =>
      option_rel (globvar_rel (fun v_from v_to => convert_globalvar v_from = v_to)).

  Hypothesis convert_primitive_to_program:
    forall i f f_,
      make_external D_from i f = OK f_ ->
      forall fto_,
        make_external D_to i (convert_primsem i f) = OK fto_ ->
        transf_F_prog f_ = OK fto_.

  Variables (make_varinfo_from: Vm_from -> V_prog_from).
  Variables (make_varinfo_to: Vm_to -> V_prog_to).

  Hypothesis make_varinfo_from_map:
    forall v v',
    make_varinfo v = OK v' ->
    v' = globvar_map make_varinfo_from v.

  Hypothesis make_varinfo_to_map:
    forall v v',
    make_varinfo v = OK v' ->
    v' = globvar_map make_varinfo_to v.

  Hypothesis transf_V_module_to_program:
    forall v,
      transf_V_prog (make_varinfo_from v) = OK (make_varinfo_to (convert_globalvar v)).

  Local Instance make_program_relations:
    MakeProgramRelations D_from D_to RF_module RV_module RF_prog RV_prog.
  Proof.
    split.
    * intros i.
      red.
      unfold RF_module.
      inversion 1; subst; congruence.
    * intros i.
      red.
      unfold RV_module.
      inversion 1; subst; congruence.
    * repeat red.
      unfold RF_module.
      intros i x y H x0 y0 H0 H1.
      inversion H; clear H; subst.
      + inversion H1; clear H1; subst.
        inversion H0; clear H0; subst.
        inversion H3; clear H3; subst.
        {
          inversion H1; clear H1; subst.
          inversion H2; clear H2; subst.
          destruct H as (fp_from & make_from & fp_to & transf & make_to).
          constructor.
          congruence.
        }
        inversion H2; clear H2; subst.
        inversion H1; clear H1; subst.
        constructor.
        eauto.
      + inversion H1; clear H1; subst.
        inversion H0; clear H0; subst.
        constructor.
    * repeat red.
      unfold RV_module.
      intros i x y H x0 y0 H0 H1.
      inversion H; clear H; subst.
      + inversion H1; clear H1; subst.
        inversion H0; clear H0; subst.
        inversion H3; clear H3; subst.
        inversion H1; clear H1; subst.
        inversion H2; clear H2; subst.
        apply make_varinfo_to_map in H0.
        unfold globvar_map in H0.
        simpl in H0.
        subst.
        apply make_varinfo_from_map in H1.
        unfold globvar_map in H1.
        simpl in H1.
        subst.
        constructor.
        constructor; auto.
      + inversion H1; clear H1; subst.
        inversion H0; clear H0; subst.
        constructor.
    * intros i f1 f2 Hf.
      inversion Hf; clear Hf; subst.
      destruct H1 as [f_from f_to Hf | p_from p_to Hp].
      + destruct Hf as (fp_from & Hfp_from & fp_to & Hfp & Hfp_to).
        simpl.
        rewrite Hfp_from, Hfp_to.
        intros [err H].
        discriminate.
      + simpl.
        inversion 1.
        revert H.
        admit. (* need properties on convert_primsem vs. make_external *)
    * intros i v1 v2 Hv.
      inversion Hv; clear Hv; subst.
      destruct H1 as [v1 v2 Hv init _ [] ro _ [] vol _ []].
      admit. (* need properties on convert_globvar vs. make_varinfo *)
  Admitted.

  Local Instance make_program_relations_flip:
    MakeProgramRelations D_to D_from (fun i => flip (RF_module i)) (fun i => flip (RV_module i)) (fun i => flip (RF_prog i)) (fun i => flip (RV_prog i)).
  Proof.
    split.
    * intros i.
      red.
      unfold flip, RF_module.
      inversion 1; subst; congruence.
    * intros i.
      red.
      unfold flip, RV_module.
      inversion 1; subst; congruence.
    * repeat red.
      unfold flip, RF_module.
      intros i x y H x0 y0 H0 H1.
      inversion H; clear H; subst.
      + inversion H1; clear H1; subst.
        inversion H0; clear H0; subst.
        inversion H4; clear H4; subst.
        {
          inversion H1; clear H1; subst.
          inversion H2; clear H2; subst.
          destruct H as (fp_from & make_from & fp_to & transf & make_to).
          constructor.
          congruence.
        }
        inversion H2; clear H2; subst.
        inversion H1; clear H1; subst.
        constructor.
        eauto.
      + inversion H1; clear H1; subst.
        inversion H0; clear H0; subst.
        constructor.
    * repeat red.
      unfold flip, RV_module.
      intros i x y H x0 y0 H0 H1.
      inversion H; clear H; subst.
      + inversion H1; clear H1; subst.
        inversion H0; clear H0; subst.
        inversion H4; clear H4; subst.
        inversion H1; clear H1; subst.
        inversion H2; clear H2; subst.
        apply make_varinfo_from_map in H0.
        unfold globvar_map in H0.
        simpl in H0.
        subst.
        apply make_varinfo_to_map in H1.
        unfold globvar_map in H1.
        simpl in H1.
        subst.
        constructor.
        constructor; auto.
      + inversion H1; clear H1; subst.
        inversion H0; clear H0; subst.
        constructor.
    * intros i f1 f2 Hf.
      inversion Hf; clear Hf; subst.
      destruct H1 as [f_from f_to Hf | p_from p_to Hp].
      + destruct Hf as (fp_from & Hfp_from & fp_to & Hfp & Hfp_to).
        simpl.
        rewrite Hfp_from, Hfp_to.
        intros [err H].
        discriminate.
      + simpl.
        inversion 1.
        revert H.
        admit. (* need properties on convert_primsem vs. make_external *)
    * intros i v1 v2 Hv.
      inversion Hv; clear Hv; subst.
      destruct H1 as [v1 v2 Hv init _ [] ro _ [] vol _ []].
      admit. (* need properties on convert_globvar vs. make_varinfo *)
  Admitted.

  (* For a correctly compiled module. *)

  Variables (Mfrom: module_from) (Mto: module_to).
  Variables (Lfrom: layer_from D_from) (Lto: layer_to D_to).

  Hypothesis get_module_function_some:
    forall i ffrom,
      get_module_function i Mfrom = OK (Some ffrom) ->
      exists fto,
        get_module_function i Mto = OK (Some fto) /\
        exists fp_from,
          make_internal ffrom = OK fp_from /\
          exists fp_to,
            transf_F_prog fp_from = OK fp_to /\
            make_internal fto = OK fp_to.

  Hypothesis get_module_function_none:
    forall i,
      get_module_function i Mfrom = OK None ->
      get_module_function i Mto = OK None.

  Hypothesis get_module_variable_eq:
    forall i ffrom,
      get_module_variable i Mfrom = OK ffrom ->
      get_module_variable i Mto = OK (option_map (globvar_map convert_globalvar) ffrom).

  Hypothesis get_layer_primitive_eq:
    forall i ffrom,
      get_layer_primitive i Lfrom = OK ffrom ->
      get_layer_primitive i Lto = OK (option_map (convert_primsem i) ffrom).

  Hypothesis get_layer_globalvar_eq:
    forall i ffrom,
      get_layer_globalvar i Lfrom = OK ffrom ->
      get_layer_globalvar i Lto = OK (option_map (globvar_map convert_globalvar) ffrom).

  Lemma module_layer_rel_flip_intro:
    module_layer_rel D_to D_from (fun i : ident => flip (RF_module i))
                     (fun i : ident => flip (RV_module i)) (Mto, Lto) (Mfrom, Lfrom).
  Proof.
    unfold module_layer_rel.
    simpl.
    intros i.
    split.
    {
      unfold get_module_layer_function; simpl.
      destruct (get_module_function i Mfrom) eqn:H.
      {
        destruct (get_layer_primitive i Lfrom) eqn:H0.
        {
          apply get_layer_primitive_eq in H0.
          rewrite H0.
          destruct o.
          {
            apply get_module_function_some in H.
            destruct H as (? & H & TRANSF).
            rewrite H.
            simpl.
            destruct o0; simpl; constructor; auto.
            constructor.
            constructor.
            assumption.
          }
          apply get_module_function_none in H.
          rewrite H.
          simpl.
          destruct o0; simpl; constructor; auto; repeat constructor.
        }
        simpl.
        destruct o; constructor.
      }
      simpl.
      constructor.
    }
    unfold get_module_layer_variable; simpl.
    destruct (get_module_variable i Mfrom) as [ o | ] eqn:H; simpl.
    {
      apply get_module_variable_eq in H.
      rewrite H; clear H.
      destruct (get_layer_globalvar i Lfrom) as [ o0 | ] eqn:H0; simpl.
      {
        apply get_layer_globalvar_eq in H0.
        rewrite H0; clear H0.
        destruct o as [ g | ].
        {
          destruct o0 as [ g0 | ].
          {
            destruct (Decision.decide (g = g0)).
            {
              subst.
              autorewrite with res_option_globalvar.
              simpl.
              repeat constructor.
              destruct g0; repeat constructor.
            }
            rewrite (GlobalVars.res_option_globalvar_oplus_diff g g0) by assumption.
            constructor.
          }
          autorewrite with res_option_globalvar.
          simpl.
          repeat constructor.
          destruct g; repeat constructor.
        }
        autorewrite with res_option_globalvar.
        simpl.
        repeat constructor.
        destruct o0 as [ g0 | ]; repeat constructor.
        destruct g0; repeat constructor.
      }
      GlobalVars.res_option_globalvar_red.
      constructor.
    }
    GlobalVars.res_option_globalvar_red.
    constructor.
  Qed.

  Context `{make_program_prf: MakeProgram}.

  Lemma make_program_transform_partial_program2 pfrom pto:
    make_program _ (Mfrom, Lfrom) = OK pfrom ->
    make_program _ (Mto, Lto) = OK pto ->
    transform_partial_program2 (fun _ => transf_F_prog) (fun _ => transf_V_prog) pfrom = OK pto.
  Proof.
    intros H H0.
    generalize (make_program_rel make_program_relations_flip _ _ module_layer_rel_flip_intro).
    rewrite H.
    rewrite H0.
    inversion 1; subst.
    eapply transform_partial_program2_recip_flip; eauto.
  Qed.

  Lemma make_program_from_to_exists pfrom:
    make_program _ (Mfrom, Lfrom) = OK pfrom ->
    exists pto, make_program _ (Mto, Lto) = OK pto.
  Proof.
    intros H.
    generalize (make_program_rel make_program_relations_flip _ _ module_layer_rel_flip_intro).
    rewrite H.
    inversion 1; subst.
    eauto.
  Qed.

  Hypothesis Mfrom_OK_function:
    forall i,
      isError (get_module_function i Mfrom) ->
      isError (get_module_function i Mto).

  Hypothesis Mfrom_OK_variable:
    forall i,
      isError (get_module_variable i Mfrom) ->
      isError (get_module_variable i Mto).

  Hypothesis Lfrom_OK_primitive:
    forall i,
      isError (get_layer_primitive i Lfrom) ->
      isError (get_layer_primitive i Lto).

  Hypothesis Lfrom_OK_globalvar:
    forall i,
      isError (get_layer_globalvar i Lfrom) ->
      isError (get_layer_globalvar i Lto).

  (** The following condition is required to ensure that Mfrom, Lfrom
      do not have different global variables at the same
      symbol. Indeed, if we were to have some, and if those two global
      variables were converted to the same one, then we would have to
      prove [res_le (option_le _) (Error _) (OK _)], which obviously
      does not hold.

      The alternative is to require that [convert_globalvar] be
      injective, which is not realistic unless we use the same type for
      source and target global variables for modules and layers, and
      convert them only when translating their corresponding programs.
   *)
  Hypothesis DISJ: module_layer_disjoint Mfrom Lfrom.

  Lemma module_layer_rel_intro:
    module_layer_rel D_from D_to RF_module RV_module (Mfrom, Lfrom) (Mto, Lto).
  Proof.
    unfold module_layer_rel.
    simpl.
    intros i.
    split.
    {
      unfold get_module_layer_function; simpl.
      destruct (get_module_function i Mfrom) eqn:H.
      {
        destruct (get_layer_primitive i Lfrom) eqn:H0.
        {
          apply get_layer_primitive_eq in H0.
          rewrite H0.
          destruct o.
          {
            apply get_module_function_some in H.
            destruct H as (? & H & TRANSF).
            rewrite H.
            simpl.
            destruct o0; simpl; constructor; auto.
            constructor.
            constructor.
            assumption.
          }
          apply get_module_function_none in H.
          rewrite H.
          simpl.
          destruct o0; simpl; constructor; auto; repeat constructor.
        }
        destruct (Lfrom_OK_primitive i) as [? H1].
        { rewrite H0. econstructor. reflexivity. }
        rewrite H1.
        destruct (get_module_function i Mto).
        {
          destruct o0; constructor.
        }
        constructor.
      }
      destruct (Mfrom_OK_function i) as [? H1].
      { rewrite H. econstructor. reflexivity. }
      rewrite H1.
      constructor.
    }
    unfold get_module_layer_variable; simpl.
    destruct (get_module_variable i Mfrom) as [ o | ] eqn:H.
    {
      generalize H. intro H_.
      apply get_module_variable_eq in H.
      rewrite H; clear H.
      destruct (get_layer_globalvar i Lfrom) as [ o0 | ] eqn:H0.
      {
        generalize H0. intro H0_.
        apply get_layer_globalvar_eq in H0.
        rewrite H0; clear H0.
        destruct o as [ g | ].
        {
          destruct o0 as [ g0 | ].
          {
            assert (g = g0).
            {
              specialize (DISJ i).
              rewrite H_ in DISJ.
              rewrite H0_ in DISJ.
              inversion DISJ; congruence.
            }
            subst.
            autorewrite with res_option_globalvar.
            destruct g0; repeat constructor.
          }
          simpl.
          autorewrite with res_option_globalvar.
          destruct g; repeat constructor.
        }
        simpl.
        autorewrite with res_option_globalvar.
        destruct o0 as [ [ ] | ] ; repeat constructor.
      }
      edestruct Lfrom_OK_globalvar as [ ? EQ ]; unfold isError; eauto.
      rewrite EQ.
      res_option_globalvar_red.
      constructor.
    }
    edestruct Mfrom_OK_variable as [ ? EQ ]; unfold isError; eauto.
    rewrite EQ.
    res_option_globalvar_red.
    constructor.
  Qed.

  Lemma make_program_to_from_exists pto:
    make_program _ (Mto, Lto) = OK pto ->
    exists pfrom, make_program _ (Mfrom, Lfrom) = OK pfrom.
  Proof.
    intros H.
    generalize (make_program_rel make_program_relations _ _ module_layer_rel_intro).
    rewrite H.
    inversion 1; subst.
    eauto.
  Qed.

End TRANSFORM_PROGRAM.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export computation7.

Lemma computes_steps_prinargs_comp2 {p} :
  forall lib a ntp1 ntp2 lbt k1 k2 ntpc1 ntpc2,
    compute_at_most_k_steps lib k1 ntp1 = csuccess ntpc1
    -> iswfpk a ntpc1
    -> compute_at_most_k_steps lib k2 ntp2 = @csuccess p ntpc2
    -> {j : nat $ compute_at_most_k_steps lib j (oterm (NCan (NCompOp a))
                        ((bterm [] ntp1)::((bterm [] ntp2)::lbt)))
            = csuccess (oterm (NCan (NCompOp a))
                              ((bterm [] ntpc1)::((bterm [] ntpc2)::lbt)))
                       # j<= (k1+k2)}.
Proof.
  induction k2 as [| k2 Hind];  introv H1c H1v H2c.
  - inverts H2c.
    match goal with
    | [ |- {_ : nat $ compute_at_most_k_steps _ _
          (oterm (NCan ?no) (?h :: ?tl)) = _ # _ }] =>
     apply @computes_atmost_ksteps_prinarg with (lbt:= tl)
      (op:=no) in H1c
    end.
    exrepnd. exists j. dands; spc. omega.
  - rename H2c into Hck. rename k2 into k.
    destruct ntp2 as [|f|ntp2o ntp2lbt];
      [rw @compute_at_most_steps_var in Hck; spc; fail| |].

    { rw @compute_at_most_k_steps_isvalue_like in Hck; eauto 3 with slow; ginv.
      pose proof (Hind ntpc1 (sterm f)) as h; clear Hind.
      repeat (autodimp h hyp).
      { rw @compute_at_most_k_steps_isvalue_like; eauto 3 with slow; ginv. }
      exrepnd.
      eexists; dands; eauto; try omega. }

    allsimpl.
    remember (compute_at_most_k_steps lib k (oterm ntp2o ntp2lbt)) as ck.
    destruct ck as [csk | cf]; spc;[].
    pose proof (Hind _ csk H1c H1v eq_refl) as XX. exrepnd.
    destruct csk as [sckv|f| csko csklbt]; [inverts Hck; fail| |].

    { csunf Hck; allsimpl; ginv.
      pose proof (Hind ntpc1 (sterm f)) as h; clear Hind.
      repeat (autodimp h hyp).
      exrepnd.
      eexists; dands; eauto; try omega. }

    dopid csko as [cskoc| cskon | cskexc | cskabs] Case.
    + Case "Can".
      simpl in Hck. inverts Hck. exists j; sp. omega.
    + Case "NCan".
      exists (S j). dands;[|omega].
      allsimpl.
      rw XX1.
      unfold iswfpk in H1v; destruct a.
      * unfold isinteger in H1v; exrepnd; subst.
        csunf; simpl.
        rw Hck;sp.
      * unfold ispk in H1v; exrepnd; subst.
        csunf; simpl; allrw @pk2term_eq; dcwf h; allsimpl;
        try (rw Hck;sp);[].
        unfold co_wf in Heqh; allrw @get_param_from_cop_pk2can; ginv.
    + Case "Exc".
      rw @compute_step_exception in Hck; sp; inversion Hck; subst; GC.
      exists j; sp; omega.
    + Case "Abs".
      exists (S j). dands;[|omega].
      simpl.
      rw XX1.
      unfold iswfpk in H1v; destruct a.
      * unfold isinteger in H1v; exrepnd; subst.
        csunf; simpl.
        rw Hck;sp.
      * unfold ispk in H1v; exrepnd; subst.
        csunf; simpl; allrw @pk2term_eq; dcwf h; allsimpl;
        try (rw Hck;sp);[].
        unfold co_wf in Heqh; allrw @get_param_from_cop_pk2can; ginv.
Qed.

Lemma reduce_to_prinargs_comp2 {p} :
  forall lib a (ntp1 ntp2 : @NTerm p) lbt ntpv1 ntpc2,
    reduces_to lib ntp1 ntpv1
    -> iswfpk a ntpv1
    -> reduces_to lib ntp2 ntpc2
    -> reduces_to lib (oterm (NCan (NCompOp a))
                             ((bterm [] ntp1)::((bterm [] ntp2)::lbt)))
                  (oterm (NCan (NCompOp a))
                         ((bterm [] ntpv1)::((bterm [] ntpc2)::lbt))).
Proof.
  introv H1c isc H2c.
  repnud H2c.
  repnud H1c.
  exrepnd.
  eapply @computes_steps_prinargs_comp2
  with (lbt:=lbt)
         (a:=a)
         (ntpc1:= ntpv1)
         (ntpc2:= ntpc2) in H1c0;
    exrepnd; eauto.
  unfolds_base; exists j; eauto.
Qed.

Lemma computes_steps_prinargs_arith2 {p} :
  forall lib a ntp1 ntp2 lbt k1 k2 ntpc1 ntpc2,
    compute_at_most_k_steps lib k1 ntp1 = csuccess ntpc1
    -> isinteger ntpc1
    -> compute_at_most_k_steps lib k2 ntp2 = @csuccess p ntpc2
    -> {j : nat $ compute_at_most_k_steps lib j (oterm (NCan (NArithOp a))
                        ((bterm [] ntp1)::((bterm [] ntp2)::lbt)))
            = csuccess (oterm (NCan (NArithOp a))
                              ((bterm [] ntpc1)::((bterm [] ntpc2)::lbt)))
                       # j<= (k1+k2)}.
Proof.
  induction k2 as [| k2 Hind];  introv H1c H1v H2c.
  - inverts H2c.
    match goal with
    | [ |- {_ : nat $ compute_at_most_k_steps _ _
          (oterm (NCan ?no) (?h :: ?tl)) = _ # _ }] =>
     apply @computes_atmost_ksteps_prinarg with (lbt:= tl)
      (op:=no) in H1c
    end.
    exrepnd. exists j. dands; spc. omega.
  - rename H2c into Hck. rename k2 into k.
    destruct ntp2 as [|f|ntp2o ntp2lbt];
      [rw @compute_at_most_steps_var in Hck; spc; fail| |].

    { rw @compute_at_most_k_steps_isvalue_like in Hck; eauto 3 with slow; ginv.
      pose proof (Hind ntpc1 (sterm f)) as h; clear Hind.
      repeat (autodimp h hyp).
      { rw @compute_at_most_k_steps_isvalue_like; eauto 3 with slow; ginv. }
      exrepnd.
      eexists; dands; eauto; try omega. }

    allsimpl.
    remember (compute_at_most_k_steps lib k (oterm ntp2o ntp2lbt)) as ck.
    destruct ck as [csk | cf]; spc;[].
    pose proof (Hind _ csk H1c H1v eq_refl) as XX. exrepnd.
    unfold isinteger in H1v; exrepnd; subst.
    destruct csk as [sckv|f|csko csklbt]; [inverts Hck; fail| |].

    { csunf Hck; allsimpl; ginv.
      pose proof (Hind (mk_integer z) (sterm f)) as h; clear Hind.
      repeat (autodimp h hyp); eauto 3 with slow.
      exrepnd.
      eexists; dands; eauto; try omega. }

    dopid csko as [cskoc| cskon | cskexc | cskabs] Case.
    + Case "Can".
      simpl in Hck. inverts Hck. exists j; sp. omega.
    + Case "NCan".
      exists (S j). dands;[|omega].
      simpl.
      rw XX1.
      csunf; simpl.
      rw Hck;sp.
    + Case "Exc".
      rw @compute_step_exception in Hck; sp; inversion Hck; subst; GC.
      exists j; sp; omega.
    + Case "Abs".
      exists (S j). dands;[|omega].
      simpl.
      rw XX1.
      csunf; simpl.
      rw Hck;sp.
Qed.

Lemma reduce_to_prinargs_arith2 {p} :
  forall lib a (ntp1 ntp2 : @NTerm p) lbt ntpv1 ntpc2,
    reduces_to lib ntp1 ntpv1
    -> isinteger ntpv1
    -> reduces_to lib ntp2 ntpc2
    -> reduces_to lib (oterm (NCan (NArithOp a))
                             ((bterm [] ntp1)::((bterm [] ntp2)::lbt)))
                  (oterm (NCan (NArithOp a))
                         ((bterm [] ntpv1)::((bterm [] ntpc2)::lbt))).
Proof.
  introv H1c isc H2c.
  repnud H2c.
  repnud H1c.
  exrepnd.
  eapply @computes_steps_prinargs_arith2
  with (lbt:=lbt)
         (a:=a)
         (ntpc1:= ntpv1)
         (ntpc2:= ntpc2) in H1c0;
    exrepnd; eauto.
  unfolds_base; exists j; eauto.
Qed.

Lemma reduces_to_fresh2 {o} :
  forall (lib : library) (t u : @NTerm o) (v : NVar) a,
  wf_term t
  -> !LIn a (get_utokens t)
  -> reduces_to lib (subst t v (mk_utoken a)) u
  -> {z : NTerm
      $ reduces_to lib (mk_fresh v t) (mk_fresh v z)
      # alpha_eq z (subst_utokens u [(a, mk_var v)])}.
Proof.
  introv w ni r.

  pose proof (reduces_to_change_utok_sub
                lib t u
                [(v,mk_utoken a)]
                [(v,mk_utoken (get_fresh_atom t))]) as r'.
  allrw @get_utokens_sub_cons; allrw @get_utokens_sub_nil; allsimpl.
  allrw disjoint_singleton_l.
  repeat (autodimp r' hyp); eauto 3 with slow.
  { apply nr_ut_sub_cons; eauto with slow.
    intro i; apply get_fresh_atom_prop. }
  { apply get_fresh_atom_prop. }
  exrepnd.

  allrw disjoint_singleton_l.
  allrw @fold_subst.

  pose proof (reduces_to_fresh lib t s v) as h; simpl in h.
  repeat (autodimp h hyp); exrepnd.
  exists z; dands; auto.

  remember (get_fresh_atom t) as a'.

  pose proof (alpha_eq_subst_utokens
                s (subst w0 v (mk_utoken a'))
                [(a', mk_var v)]
                [(a', mk_var v)]) as aeqs1.
  repeat (autodimp aeqs1 hyp); eauto 3 with slow.
  pose proof (simple_alphaeq_subst_utokens_subst w0 v a') as aeqs2.
  autodimp aeqs2 hyp.
  { subst; intro i; apply r'4 in i; apply get_fresh_atom_prop in i; sp. }
  eapply alpha_eq_trans in aeqs2;[|exact aeqs1]; clear aeqs1.
  eapply alpha_eq_trans in aeqs2;[|exact h0].
  eapply alpha_eq_trans;[exact aeqs2|].

  pose proof (alpha_eq_subst_utokens
                u (subst w0 v (mk_utoken a))
                [(a, mk_var v)]
                [(a, mk_var v)]) as aeqs1.
  repeat (autodimp aeqs1 hyp); eauto 3 with slow.
  pose proof (simple_alphaeq_subst_utokens_subst w0 v a) as aeqs3.
  autodimp aeqs3 hyp.
  eapply alpha_eq_trans in aeqs3;[|exact aeqs1]; eauto with slow.
Qed.

Lemma alpha_eq_subst_utokens_same {o} :
  forall (t1 t2 : @NTerm o) (s : utok_sub),
    alpha_eq t1 t2
    -> alpha_eq (subst_utokens t1 s) (subst_utokens t2 s).
Proof.
  introv aeq.
  apply alpha_eq_subst_utokens; eauto with slow.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/")
*** End:
*)


Require Import VST.floyd.proofauto.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha.
Require Export sha.pure_lemmas.
Require Export sha.general_lemmas.
Export ListNotations.

Local Open Scope logic.

Global Opaque K256.

Transparent peq.

Lemma mapsto_tc_val:
  forall sh t p v,
  readable_share sh ->
  v <> Vundef ->
  mapsto sh t p v = !! tc_val t v && mapsto sh t p v .
Proof.
intros.
apply pred_ext; [ | normalize].
apply andp_right; auto.
unfold mapsto; simpl.
destruct (access_mode t); try apply FF_left.
destruct (attr_volatile (attr_of_type t)); try apply FF_left.
destruct p; try apply FF_left.
if_tac; try contradiction. apply orp_left.
normalize.
normalize.
Qed.

Fixpoint loops (s: statement) : list statement :=
 match s with
  | Ssequence a b => loops a ++ loops b
  | Sloop _ _ => [s]
  | Sifthenelse _ a b => loops a ++ loops b
  | _ => nil
  end.

Lemma nth_big_endian_integer:
  forall i bl w,
   nth_error bl i = Some w ->
    w = big_endian_integer
                   (sublist (Z.of_nat i * WORD)
                        (Z.succ (Z.of_nat i) * WORD)
                   (map Int.repr (intlist_to_Zlist bl))).
Proof.
induction i; destruct bl; intros; inv H.
*
 unfold sublist; simpl.
 rewrite big_endian_integer4.
 repeat rewrite Int.repr_unsigned.
 assert (Int.zwordsize=32)%Z by reflexivity.
 unfold Z_to_Int, Shr; simpl.
 change 255%Z with (Z.ones 8).
 apply Int.same_bits_eq; intros;
 autorewrite with testbit.
 if_tac; simpl.
 if_tac; simpl.
 if_tac; simpl; autorewrite with testbit. auto. f_equal; omega.
 rewrite if_false by omega. autorewrite with testbit. f_equal; omega.
 rewrite if_false by omega. rewrite if_false by omega.
 autorewrite with testbit. f_equal; omega.
*
specialize (IHi _ _ H1); clear H1.
simpl map.
rewrite IHi.
unfold sublist.
replace (Z.to_nat (Z.of_nat (S i) * WORD)) with (4 + Z.to_nat (Z.of_nat i * WORD))%nat
  by (rewrite plus_comm, inj_S; unfold Z.succ; rewrite Z.mul_add_distr_r;
        rewrite Z2Nat.inj_add by (change WORD with 4; omega); reflexivity).
rewrite <- skipn_skipn.
simpl skipn.
f_equal. f_equal. f_equal. rewrite inj_S.  unfold Z.succ.
rewrite !Z.mul_add_distr_r; omega.
Qed.

Lemma Znth_big_endian_integer:
  forall i bl,
   0 <= i < Zlength bl ->
   Znth i bl Int.zero =
     big_endian_integer
                   (sublist (i * WORD) (Z.succ i * WORD)
                   (map Int.repr (intlist_to_Zlist bl))).
Proof.
intros.
unfold Znth.
 rewrite if_false by omega.
pose proof (nth_error_nth _ Int.zero (Z.to_nat i) bl).
rewrite <- (Z2Nat.id i) at 2 3 by omega.
apply nth_big_endian_integer.
apply H0.
apply Nat2Z.inj_lt.
rewrite Z2Nat.id by omega.
rewrite <- Zlength_correct; omega.
Qed.

Fixpoint sequence (cs: list statement) s :=
 match cs with
 | nil => s
 | c::cs' => Ssequence c (sequence cs' s)
 end.

Fixpoint rsequence (cs: list statement) s :=
 match cs with
 | nil => s
 | c::cs' => Ssequence (rsequence cs' s) c
 end.

Lemma sequence_rsequence:
 forall Espec CS Delta P cs s0 s R,
    @semax CS Espec Delta P (Ssequence s0 (sequence cs s)) R  <->
  @semax CS Espec Delta P (Ssequence (rsequence (rev cs) s0) s) R.
Proof.
intros.
revert Delta P R s0 s; induction cs; intros.
simpl. apply iff_refl.
simpl.
rewrite seq_assoc.
rewrite IHcs; clear IHcs.
replace (rsequence (rev cs ++ [a]) s0) with
    (rsequence (rev cs) (Ssequence s0 a)); [apply iff_refl | ].
revert s0 a; induction (rev cs); simpl; intros; auto.
rewrite IHl. auto.
Qed.

Lemma seq_assocN:
  forall {Espec: OracleKind} CS,
   forall Q Delta P cs s R,
        @semax CS Espec Delta P (sequence cs Sskip) (normal_ret_assert Q) ->
         @semax CS Espec
       (update_tycon Delta (sequence cs Sskip)) Q s R ->
        @semax CS Espec Delta P (sequence cs s) R.
Proof.
intros.
rewrite semax_skip_seq.
rewrite sequence_rsequence.
rewrite semax_skip_seq in H.
rewrite sequence_rsequence in H.
rewrite <- semax_seq_skip in H.
eapply semax_seq'; [apply H | ].
eapply semax_extensionality_Delta; try apply H0.
clear.
revert Delta; induction cs; simpl; intros.
apply tycontext_sub_refl.
eapply tycontext_sub_trans; [apply IHcs | ].
clear.
revert Delta; induction (rev cs); simpl; intros.
apply tycontext_sub_refl.
apply update_tycon_sub.
apply IHl.
Qed.

Fixpoint sequenceN (n: nat) (s: statement) : list statement :=
 match n, s with
 | S n', Ssequence a s' => a::sequenceN n' s'
 | _, _ => nil
 end.

Lemma data_block_local_facts:
 forall {cs: compspecs} sh f data,
  data_block sh f data |--
   prop (field_compatible (tarray tuchar (Zlength f)) [] data
           /\ Forall isbyteZ f).
Proof.
intros. unfold data_block, array_at.
simpl.
entailer.
Qed.
Hint Resolve @data_block_local_facts : saturate_local.

Require Import JMeq.

Lemma reptype_tarray {cs: compspecs}:
   forall t len, reptype (tarray t len) = list (reptype t).
Proof.
intros.
rewrite reptype_eq. simpl. reflexivity.
Qed.

Local Open Scope nat.

(*** Application of Omega stuff ***)

Lemma CBLOCKz_eq : CBLOCKz = 64%Z.
Proof. reflexivity. Qed.
Lemma LBLOCKz_eq : LBLOCKz = 16%Z.
Proof. reflexivity. Qed.

Ltac helper2 :=
 match goal with
   | |- context [CBLOCK] => add_nonredundant (CBLOCK_eq)
   | |- context [LBLOCK] => add_nonredundant (LBLOCK_eq)
   | |- context [CBLOCKz] => add_nonredundant (CBLOCKz_eq)
   | |- context [LBLOCKz] => add_nonredundant (LBLOCKz_eq)
   | H: context [CBLOCK] |- _ => add_nonredundant (CBLOCK_eq)
   | H: context [LBLOCK] |- _ => add_nonredundant (LBLOCK_eq)
   | H: context [CBLOCKz] |- _ => add_nonredundant (CBLOCKz_eq)
   | H: context [LBLOCKz] |- _ => add_nonredundant (LBLOCKz_eq)
  end.

Ltac Omega1 := Omega (helper1 || helper2).

Ltac MyOmega :=
  rewrite ?length_list_repeat, ?skipn_length, ?map_length,
   ?Zlength_map, ?Zlength_nil;
  pose proof CBLOCK_eq;
  pose proof CBLOCKz_eq;
  pose proof LBLOCK_eq;
  pose proof LBLOCKz_eq;
  Omega1.
(*** End Omega stuff ***)

Local Open Scope Z.

Local Open Scope logic.

Lemma data_block_valid_pointer {cs: compspecs} sh l p: sepalg.nonidentity sh -> Zlength l > 0 ->
      data_block sh l p |-- valid_pointer p.
Proof. unfold data_block. simpl; intros.
  apply andp_valid_pointer2. apply data_at_valid_ptr; auto; simpl.
  rewrite Z.max_r, Z.mul_1_l; omega.
Qed.

Lemma data_block_isbyteZ {cs: compspecs}:
 forall sh data v, data_block sh data v = !! Forall isbyteZ data && data_block sh data v.
Proof.
unfold data_block; intros.
simpl.
normalize.
f_equal. f_equal. apply prop_ext. intuition.
Qed.

Lemma sizeof_tarray_tuchar:
 forall (n:Z), (n>=0)%Z -> (sizeof (tarray tuchar n) =  n)%Z.
Proof. intros.
 unfold sizeof,tarray; cbv beta iota.
  rewrite Z.max_r by omega.
  unfold alignof, tuchar; cbv beta iota.
  rewrite Z.mul_1_l. auto.
Qed.

Lemma isbyte_value_fits_tuchar:
  forall x, isbyteZ x -> value_fits tuchar (Vint (Int.repr x)).
Proof.
intros. hnf in H|-*; intros.
simpl. rewrite Int.unsigned_repr by rep_omega.
  change Byte.max_unsigned with 255%Z. omega.
Qed.

Lemma Zlength_Zlist_to_intlist:
  forall (n:Z) (l: list Z),
   (Zlength l = WORD*n)%Z -> Zlength (Zlist_to_intlist l) = n.
Proof.
intros.
rewrite Zlength_correct in *.
assert (0 <= n)%Z by ( change WORD with 4%Z in H; omega).
rewrite (length_Zlist_to_intlist (Z.to_nat n)).
apply Z2Nat.id; auto.
apply Nat2Z.inj. rewrite H.
rewrite Nat2Z.inj_mul.
f_equal. rewrite Z2Nat.id; omega.
Qed.

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

Hint Resolve isbyteZ_sublist.

Lemma split2_data_block:
  forall  {cs: compspecs}  n sh data d,
  (0 <= n <= Zlength data)%Z ->
  data_block sh data d =
  (data_block sh (sublist 0 n data) d *
   data_block sh (sublist n (Zlength data) data)
   (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc n] d))%logic.
Proof.
  intros.
  unfold data_block. simpl. normalize.
  f_equal. f_equal.
  apply prop_ext.
  split; intro. split; apply Forall_sublist; auto.
  erewrite <- (sublist_same 0 (Zlength data)); auto.
  rewrite (sublist_split 0 n) by omega.
  apply Forall_app; auto.
  rewrite <- !sublist_map.
  unfold tarray.
  rewrite split2_data_at_Tarray_tuchar with (n1:=n) by (autorewrite with sublist; auto).
  autorewrite with sublist.
  reflexivity.
Qed.

Lemma split3_data_block:
  forall  {cs: compspecs} lo hi sh data d,
  0 <= lo <= hi ->
  hi <= Zlength data  ->
  data_block sh data d =
  (data_block sh (sublist 0 lo data) d *
   data_block sh (sublist lo hi data)
   (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc lo] d) *
   data_block sh (sublist hi (Zlength data) data)
   (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc hi] d))%logic.
Proof.
  intros.
  unfold data_block. simpl. normalize.
  f_equal. f_equal.
  apply prop_ext.
  split; intro. split3; apply Forall_sublist; auto.
  erewrite <- (sublist_same 0 (Zlength data)); auto.
  rewrite (sublist_split 0 lo (Zlength data)) by omega.
  rewrite (sublist_split lo hi (Zlength data)) by omega.
  destruct H1 as [? [? ?]].
  repeat (apply Forall_app; split);  auto.
  rewrite <- !sublist_map.
  unfold tarray.
  rewrite split3_data_at_Tarray_tuchar with (n1:=lo)(n2:=hi) by (autorewrite with sublist; auto).
  autorewrite with sublist.
  reflexivity.
Qed.

Global Opaque WORD.

Lemma S256abs_data:
  forall hashed data,
   (LBLOCKz | Zlength hashed) ->
   Zlength data < CBLOCKz ->
   s256a_data (S256abs hashed data) = data.
Proof.
intros. unfold S256abs, s256a_data.
rewrite Zlength_app.
rewrite Zlength_intlist_to_Zlist.
destruct H as [n ?].
rewrite H.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (n * CBLOCKz + Zlength data) CBLOCKz H1).
pose proof (Zmod_eq (Zlength data) CBLOCKz H1).
pose proof (Zlength_nonneg data).
rewrite sublist_app2; rewrite Zlength_intlist_to_Zlist; rewrite H;
 rewrite <- Z.mul_assoc; change (LBLOCKz * 4)%Z with CBLOCKz.
apply sublist_same.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega. omega.
omega.
rewrite Z.div_add_l by  omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.
split; [ | omega].
apply Z.mul_nonneg_nonneg.
clear - H.
assert (n < 0 \/ 0 <= n) by omega.
destruct H0; auto.
pose proof (Zlength_nonneg hashed).
assert (n * LBLOCKz < 0).
apply Z.mul_neg_pos; auto.
omega.
omega.
Qed.

Lemma S256abs_hashed:
  forall hashed data,
   (LBLOCKz | Zlength hashed) ->
   Zlength data < CBLOCKz ->
   s256a_hashed (S256abs hashed data) = hashed.
Proof.
intros;  unfold S256abs, s256a_hashed.
rewrite Zlength_app.
rewrite Zlength_intlist_to_Zlist.
destruct H as [n ?].
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (n * CBLOCKz + Zlength data) CBLOCKz H1).
pose proof (Zmod_eq (Zlength data) CBLOCKz H1).
pose proof (Zlength_nonneg data).
rewrite sublist_app1; rewrite ?Zlength_intlist_to_Zlist;
  rewrite H.
rewrite sublist_same; try omega.
apply intlist_to_Zlist_to_intlist.
rewrite Zlength_intlist_to_Zlist.
  rewrite H.
rewrite <- Z.mul_assoc; change (LBLOCKz*4)%Z with CBLOCKz.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.  omega.
split; [omega | ].
rewrite <- Z.mul_assoc; change (LBLOCKz*4)%Z with CBLOCKz.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.
clear - H.
assert (n < 0 \/ 0 <= n) by omega.
simpl.
destruct H0.
pose proof (Zlength_nonneg hashed).
assert (n * LBLOCKz < 0).
apply Z.mul_neg_pos; auto.
omega.
rewrite Z.add_0_r.
apply Z.mul_nonneg_nonneg; auto.
rewrite <- Z.mul_assoc; change (LBLOCKz*4)%Z with CBLOCKz.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.  omega.
Qed.

Lemma s256a_hashed_divides:
  forall a, (LBLOCKz | Zlength (s256a_hashed a)).
Proof.
intros. unfold s256a_hashed.
exists (Zlength a / CBLOCKz)%Z.
erewrite Zlength_Zlist_to_intlist; [reflexivity |].
rewrite Zlength_sublist.
rewrite (Z.mul_comm WORD).
rewrite <- Z.mul_assoc.
change (LBLOCKz * WORD)%Z with CBLOCKz.
omega.
split; [ omega  |] .
apply Z.mul_nonneg_nonneg; auto.
apply Z.div_pos.
apply Zlength_nonneg.
rewrite CBLOCKz_eq; omega.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
omega.
Qed.

Lemma s256a_data_len:
  forall a: s256abs,
  Zlength (s256a_data a) = Zlength a mod CBLOCKz.
Proof.
intros.
unfold s256a_data.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
rewrite H0.
rewrite Zlength_sublist; try omega.
split; try omega.
apply Z.mul_nonneg_nonneg.
apply Z.div_pos.
apply Zlength_nonneg.
omega. omega.
Qed.

Lemma s256a_data_Zlength_less:
  forall a, Zlength (s256a_data a) < CBLOCKz.
Proof.
intros.
rewrite s256a_data_len.
apply Z_mod_lt.
rewrite CBLOCKz_eq; omega.
Qed.

Lemma hashed_data_recombine:
  forall a,
     Forall isbyteZ a ->
    intlist_to_Zlist (s256a_hashed a) ++ s256a_data a = a.
Proof.
intros. rename H into BYTES.
unfold s256a_hashed, s256a_data.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
rewrite Zlist_to_intlist_to_Zlist.
rewrite sublist_rejoin.
autorewrite with sublist. auto.
split; [ omega  |] .
apply Z.mul_nonneg_nonneg; auto.
apply Z.div_pos.
apply Zlength_nonneg.
rewrite CBLOCKz_eq; omega.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
omega.
rewrite Zlength_sublist.
rewrite Z.sub_0_r.
apply Z.divide_mul_r.
exists LBLOCKz. reflexivity.
split; [ omega  |] .
apply Z.mul_nonneg_nonneg; auto.
apply Z.div_pos.
apply Zlength_nonneg.
omega.
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
omega.
apply Forall_sublist.
auto.
Qed.

Definition bitlength (hashed: list int) (data: list Z) : Z :=
   ((Zlength hashed * WORD + Zlength data) * 8)%Z.

Lemma bitlength_eq:
  forall hashed data,
  bitlength hashed data = s256a_len (S256abs hashed data).
Proof.
intros.
unfold bitlength, s256a_len, S256abs.
rewrite Zlength_app.
rewrite Zlength_intlist_to_Zlist.
reflexivity.
Qed.

Lemma S256abs_recombine:
 forall a, Forall isbyteZ a ->
    S256abs (s256a_hashed a) (s256a_data a) = a.
Proof.
intros.
apply hashed_data_recombine; auto.
Qed.

Lemma Zlist_to_intlist_app:
  forall a b,
  (WORD | Zlength a) ->
   Zlist_to_intlist (a++b) = Zlist_to_intlist a ++ Zlist_to_intlist b.
Proof.
intros.
destruct H as [na H].
rewrite <- (Z2Nat.id na) in H.
Focus 2.
destruct (zlt na 0); try omega.
assert (na * WORD < 0); [apply Z.mul_neg_pos; auto | ].
pose proof (Zlength_nonneg a); omega.
revert a H; induction (Z.to_nat na); intros.
simpl in H. destruct a. simpl. auto. rewrite Zlength_cons in H.
pose proof (Zlength_nonneg a); omega.
rewrite inj_S in H.
unfold Z.succ in H. rewrite Z.mul_add_distr_r in H.
change (1*WORD)%Z with 4 in H.
assert (Zlength a >= 4).
assert (0 <= Z.of_nat n * WORD); [ | omega].
apply Z.mul_nonneg_nonneg; try omega.
change WORD with 4%Z; omega.
do 4 (destruct a; [rewrite Zlength_nil in H0; omega | rewrite Zlength_cons in H,H0  ]).
simpl.
do 4 f_equal. apply IHn.
omega.
Qed.

Lemma round_range:
 forall {A} (a: list A) (N:Z),
  N > 0 ->
   0 <= Zlength a / N * N <= Zlength a.
Proof.
intros.
split.
apply Z.mul_nonneg_nonneg; auto; try omega.
apply Z.div_pos; try omega.
apply Zlength_nonneg.
pose proof (Zmod_eq (Zlength a) N H).
pose proof (Z_mod_lt (Zlength a) N H).
omega.
Qed.

Lemma CBLOCKz_gt: CBLOCKz > 0.
Proof. rewrite CBLOCKz_eq; omega.
Qed.

Lemma Zlist_to_intlist_inj:
  forall a b,
   (WORD | Zlength a) ->
   (WORD | Zlength b) ->
   Forall isbyteZ a ->
   Forall isbyteZ b ->
   Zlist_to_intlist a = Zlist_to_intlist b ->
   a=b.
Proof.
intros.
rewrite <- (Zlist_to_intlist_to_Zlist a) by auto.
rewrite H3.
apply Zlist_to_intlist_to_Zlist; auto.
Qed.

Definition update_abs (incr: list Z) (a: list Z) (a': list Z) :=
    a' = a ++ incr.

Lemma update_abs_eq:
  forall msg a a',
 Forall isbyteZ (a++msg) ->
 Forall isbyteZ a' ->
 (update_abs msg a a' <->
  exists blocks,
    s256a_hashed a' = s256a_hashed a ++ blocks /\
    s256a_data a ++ msg = intlist_to_Zlist blocks ++ s256a_data a').
Proof.
intros. rename H0 into H'.
unfold update_abs.
assert (0 <= 0 <= Zlength a / CBLOCKz * CBLOCKz). {
 split; [omega | ].
 apply Z.mul_nonneg_nonneg.
 apply Z.div_pos.
 apply Zlength_nonneg.
 rewrite CBLOCKz_eq; omega.
 rewrite CBLOCKz_eq; omega.
}
pose proof (round_range a _ CBLOCKz_gt).
pose proof (round_range (a++msg) _ CBLOCKz_gt).
split; intro.
*
subst a'.
unfold s256a_hashed.
exists (Zlist_to_intlist
            (sublist (Zlength a / CBLOCKz * CBLOCKz) (Zlength (a++msg) / CBLOCKz * CBLOCKz)
                  (a++msg))).
split.
 +
 rewrite (sublist_split 0 (Zlength a / CBLOCKz * CBLOCKz)); auto.
 rewrite Zlist_to_intlist_app.
 f_equal.
 rewrite sublist_app1; auto. omega.
 rewrite Zlength_sublist; auto.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 rewrite Zlength_app.
 pose proof (Zlength_nonneg msg); omega.
 split; [ | apply round_range; apply CBLOCKz_gt].
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
 rewrite Zlength_app; Omega1.
 +
 rewrite Zlist_to_intlist_to_Zlist.
 Focus 2. rewrite Zlength_sublist. rewrite <- Z.mul_sub_distr_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 split; [Omega1 | ].
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
 rewrite Zlength_app; Omega1.
 apply round_range. apply CBLOCKz_gt.
 2: apply Forall_sublist; auto.
 unfold s256a_data.
 destruct (zlt   (Zlength (a ++ msg) / CBLOCKz * CBLOCKz) (Zlength a) ).
  -
   rewrite sublist_app1; try omega.
   rewrite (sublist_split (Zlength (a ++ msg) / CBLOCKz * CBLOCKz)
               (Zlength a) (Zlength (a ++ msg))); try omega.
   rewrite sublist_app1; try omega.
   rewrite sublist_app2 by omega.
   autorewrite with sublist.
   rewrite (sublist_same 0) by omega.
   rewrite <- app_ass. f_equal.
   rewrite sublist_rejoin; try omega. auto.
   split. apply round_range; apply CBLOCKz_gt.
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
  Omega1.
  rewrite Zlength_app in l; omega.
  rewrite Zlength_app; Omega1.
   split. apply round_range; apply CBLOCKz_gt.
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
  rewrite Zlength_app; Omega1.
 -
   rewrite (sublist_split (Zlength a / CBLOCKz * CBLOCKz) (Zlength a)
                  (Zlength (a ++ msg) / CBLOCKz * CBLOCKz) ); auto.
   rewrite app_ass.
   rewrite sublist_app1; try omega.
   rewrite sublist_app2; try omega.
   rewrite Z.sub_diag.
   f_equal.
   rewrite sublist_app2; try omega.
   rewrite sublist_rejoin.
   autorewrite with sublist. auto.
   omega.
  split; try omega. rewrite Zlength_app; Omega1.
   omega.
*
destruct H3 as [blocks [? ?]].
match type of H3 with ?A = ?B =>
  assert (Zlength A * WORD = Zlength B * WORD)%Z by congruence
end.
match type of H4 with ?A = ?B =>
  assert (sublist 0 (Zlength a / CBLOCKz * CBLOCKz) a ++ A =
              sublist 0 (Zlength a / CBLOCKz * CBLOCKz) a ++ B) by congruence
end.
unfold s256a_hashed, s256a_data in *.
rewrite <- app_ass in H6.
rewrite sublist_rejoin in H6 by omega.
rewrite sublist_same in H6 by omega.
rewrite H6.
clear H6 H4.
rewrite <- (sublist_same 0 (Zlength a') a') at 1; auto.
rewrite <- app_ass.
rewrite (sublist_split 0 (Zlength a' / CBLOCKz * CBLOCKz) (Zlength a')); try omega.
f_equal.
apply Zlist_to_intlist_inj.
rewrite Zlength_sublist.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 split; [clear; omega | ].
 apply Z.mul_nonneg_nonneg; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_pos; [ | rewrite CBLOCKz_eq; omega].
 apply Zlength_nonneg.
 apply round_range; apply CBLOCKz_gt.
 rewrite Zlength_app.
 apply Z.divide_add_r.
rewrite Zlength_sublist.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 split; [clear; omega | ].
 apply Z.mul_nonneg_nonneg; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_pos; [ | rewrite CBLOCKz_eq; omega].
 apply Zlength_nonneg.
 apply round_range; apply CBLOCKz_gt.
 exists (Zlength blocks).
 apply Zlength_intlist_to_Zlist.
 apply Forall_sublist; auto.
 apply Forall_app; split.
 apply Forall_app in H; destruct H;
 apply Forall_sublist; auto.
 apply isbyte_intlist_to_Zlist.
 rewrite H3.
 rewrite Zlist_to_intlist_app. f_equal.
 symmetry; apply intlist_to_Zlist_to_intlist.
rewrite Zlength_sublist.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 auto.
 omega.
 split; [clear; omega |].
 apply round_range; apply CBLOCKz_gt.
 split; [ | clear; omega].
 apply round_range; apply CBLOCKz_gt.
Qed.

Lemma array_at_memory_block:
 forall {cs: compspecs} sh t gfs lo hi v p n,
  sizeof (nested_field_array_type t gfs lo hi) = n ->
  lo <= hi ->
  array_at sh t gfs lo hi v p |--
  memory_block sh n (field_address0 t (ArraySubsc lo :: gfs) p).
Proof.
intros.
rewrite  array_at_data_at by auto.
normalize.
unfold at_offset.
rewrite field_address0_offset by auto.
subst n.
apply data_at_memory_block.
Qed.

Hint Extern 2 (array_at _ _ _ _ _ _ _ |-- memory_block _ _ _) =>
   (apply array_at_memory_block; try reflexivity; try omega) : cancel.


From iris.proofmode Require Import tactics.
From mwp.mwp_modalities Require Import mwp_step_fupd.
From mwp.mwp_modalities.ni_logrel Require Import mwp_left mwp_right ni_logrel_lemmas.
From logrel_ifc.lambda_sec Require Export lattice fundamental_binary notation.

(* OBS: high observer *)
Local Instance tpSecurityLatticeH : SecurityLattice tplabel := { ζ := H }.

(* This examples shows that it does not matter if we write H information to a L
     location if the observer is H---it is all the same for the observer. *)

(* low := !high *)
Definition prog_explicit_flow :=
  ($0 <- !$1)%E.

(* ... and the same is the case for implicit flows; the observer can see the
     secret, so both conditionals will always go into the same branch. *)

(* if !high then low := true else low := false *)
Definition prg_implicit_flow :=
  (if: !$1 then $0 <- true else $0 <- false)%E.

Section related.
  Context `{!secG Σ}.

  Lemma prg_high_to_low_bi_related :
    [TRef (TBool @ (LLabel L)) @ (LLabel L); TRef (TBool @ (LLabel H)) @ (LLabel L)] ⊨
     prog_explicit_flow ≤ₗ prog_explicit_flow : TUnit @ (LLabel L).
  Proof.
    iIntros (θ ρ vvs Hpers) "[#Hcoh Henv]".
    iDestruct (interp_env_length with "Henv") as %?.
    do 2 (destruct vvs; [done|]).
    iDestruct (interp_env_cons with "Henv") as "[Hlow Henv']".
    iDestruct (interp_env_cons with "Henv'") as "[Hhigh _]".
    rewrite !interp_sec_def.
    rewrite !bool_decide_eq_true_2 // !interp_ref_def.
    iDestruct "Hlow" as ([l1 l2]) "[-> #Hlow] /=".
    iDestruct "Hhigh" as ([l1' l2']) "[-> #Hhigh] /=".
    rewrite /interp_ref_inv /= !loc_to_val.
    iApply (mwp_left_strong_bind _ _ (fill [StoreRCtx _]) (fill [StoreRCtx _])); cbn.
    iApply (mwp_double_atomic_lr _ _ StronglyAtomic).
    iInv (nroot.@(l1',l2')) as "Hl" "HcloseI".
    iDestruct "Hl" as (v1 v2) "(Hl1 & Hl2 & #Hτ) /=".
    iModIntro.
    iApply ((@mwp_step_fupd_load _ secG_un_left) with "[//]").
    iFrame. iIntros "!> Hl1".
    iApply ((@mwp_fupd_load _ secG_un_right) with "[//]").
    iFrame. iIntros "Hl2". ubools.
    rewrite bool_decide_eq_true_2 //=.
    iDestruct "Hτ" as (? b) "(-> & -> & ->)".
    iMod ("HcloseI" with "[Hl1 Hl2]") as "_".
    { iNext. iExists _,_. iFrame. ubools.
      rewrite bool_decide_eq_true_2 //. eauto. }
    iModIntro.
    iApply (mwp_double_atomic_lr _ _ StronglyAtomic).
    iInv (nroot.@(l1,l2)) as "Hl" "HcloseI".
    iDestruct "Hl" as (v1 v2) "(Hl1 & Hl2 & #Hτ) /=".
    iModIntro.
    rewrite !bool_to_val.
    iApply (@mwp_step_fupd_store _ secG_un_left); [done|].
    iFrame. iIntros "!> Hl1".
    iApply (@mwp_fupd_store _ secG_un_right); [done|].
    iFrame. iIntros "Hl2".
    rewrite interp_sec_def interp_bool_def bool_decide_eq_true_2 //=.
    iDestruct "Hτ" as (? b') "(-> & -> & ->)".
    iMod ("HcloseI" with "[Hl1 Hl2]") as "_".
    { iNext. iExists _,_. iFrame. ubools.
      rewrite bool_decide_eq_true_2 //. eauto. }
    rewrite interp_sec_def interp_unit_def bool_decide_eq_true_2 //.
  Qed.

  Lemma prg_high_ctx_to_low :
    [TRef (TBool @ (LLabel L)) @ (LLabel L); TRef (TBool @ (LLabel H)) @ (LLabel L)] ⊨
    prg_implicit_flow ≤ₗ prg_implicit_flow : TUnit @ (LLabel L).
  Proof.
    iIntros (θ ρ vvs Hpers) "[#Hcoh Henv]".
    iDestruct (interp_env_length with "Henv") as %?.
    do 2 (destruct vvs; [done|]).
    iDestruct (interp_env_cons with "Henv") as "[Hlow Henv']".
    iDestruct (interp_env_cons with "Henv'") as "[Hhigh _]".
    rewrite !interp_sec_def.
    rewrite !bool_decide_eq_true_2 // !interp_ref_def.
    iDestruct "Hlow" as ([l1 l2]) "[-> #Hlow] /=".
    iDestruct "Hhigh" as ([l1' l2']) "[-> #Hhigh] /=".
    rewrite /interp_ref_inv /= !loc_to_val !bool_to_val.
    iApply (mwp_left_strong_bind _ _ (fill [IfCtx _ _]) (fill [IfCtx _ _])).
    iApply (mwp_double_atomic_lr _ _ StronglyAtomic).
    iInv (nroot.@(l1',l2')) as "Hl" "HcloseI".
    iDestruct "Hl" as (v1 v2) "(Hl1 & Hl2 & #Hτ) /=".
    iModIntro.
    iApply ((@mwp_step_fupd_load _ secG_un_left) with "[//]").
    iFrame. iIntros "!> Hl1".
    iApply ((@mwp_fupd_load _ secG_un_right) with "[//]").
    iFrame. iIntros "Hl2".
    rewrite interp_sec_def interp_bool_def bool_decide_eq_true_2 //=.
    iDestruct "Hτ" as (? b) "(-> & -> & ->)".
    iMod ("HcloseI" with "[Hl1 Hl2]") as "_".
    { iNext. iExists _,_. iFrame. ubools.
      rewrite bool_decide_eq_true_2 //=. eauto. }
    iModIntro.
    destruct b.
    - iApply mwp_left_pure_step; [done|].
      iApply mwp_left_pure_step_index; [done|].
      iNext.
      iApply (mwp_double_atomic_lr _ _ StronglyAtomic).
      iInv (nroot.@(l1,l2)) as "Hl" "HcloseI".
      iDestruct "Hl" as (v1 v2) "(Hl1 & Hl2 & #Hτ) /=".
      iModIntro. rewrite !bool_to_val.
      iApply (@mwp_step_fupd_store _ secG_un_left); [done|].
      iFrame. iIntros "!> Hl1".
      iApply (@mwp_fupd_store _ secG_un_right); [done|].
      iFrame. iIntros "Hl2".
      rewrite interp_sec_def interp_bool_def bool_decide_eq_true_2 //=.
      iDestruct "Hτ" as (? b') "(-> & -> & ->)".
      iMod ("HcloseI" with "[Hl1 Hl2]") as "_".
      { iNext. iExists _,_. iFrame. ubools.
        rewrite bool_decide_eq_true_2 //. eauto. }
      rewrite interp_sec_def interp_unit_def bool_decide_eq_true_2 //.
    - iApply mwp_left_pure_step; [done|].
      iApply mwp_left_pure_step_index; [done|].
      iNext.
      iApply (mwp_double_atomic_lr _ _ StronglyAtomic).
      iInv (nroot.@(l1,l2)) as "Hl" "HcloseI".
      iDestruct "Hl" as (v1 v2) "(Hl1 & Hl2 & #Hτ) /=".
      iModIntro. rewrite !bool_to_val.
      iApply (@mwp_step_fupd_store _ secG_un_left); [done|].
      iFrame. iIntros "!> Hl1".
      iApply (@mwp_fupd_store _ secG_un_right); [done|].
      iFrame. iIntros "Hl2".
      rewrite interp_sec_def interp_bool_def bool_decide_eq_true_2 //=.
      iDestruct "Hτ" as (? b') "(-> & -> & ->)".
      iMod ("HcloseI" with "[Hl1 Hl2]") as "_".
      { iNext. iExists _,_. iFrame. ubools.
        rewrite bool_decide_eq_true_2 //. eauto. }
      rewrite interp_sec_def interp_unit_def bool_decide_eq_true_2 //.
  Qed.

End related.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, 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 GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for PowerPC *)

Require Import ZArith.
Require Import Fappli_IEEE.
Require Import Fappli_IEEE_bits.

Definition big_endian := true.

Notation align_int64 := 8%Z (only parsing).
Notation align_float64 := 8%Z (only parsing).

Program Definition default_pl_64 : bool * nan_pl 53 :=
  (false, iter_nat 51 _ xO xH).

Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
  false.                        (**r always choose first NaN *)

Program Definition default_pl_32 : bool * nan_pl 24 :=
  (false, iter_nat 22 _ xO xH).

Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
  false.                        (**r always choose first NaN *)

Definition float_of_single_preserves_sNaN := true.

Global Opaque big_endian
              default_pl_64 choose_binop_pl_64
              default_pl_32 choose_binop_pl_32
              float_of_single_preserves_sNaN.

(** Can we use the 64-bit extensions to the PowerPC architecture? *)
Parameter ppc64: bool.