(*
 * © 2020 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     ModelCheck
     Keys
     Automation
     Tactics
     Simulation
     AdversaryUniverse

     ModelCheck.UniverseEqAutomation
     ModelCheck.ProtocolAutomation
     ModelCheck.SafeProtocol
     ModelCheck.ProtocolFunctions
.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

From Frap Require Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Import SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module ShareSecretSymmetricEncProtocol.

  (* User ids *)
  Notation USR1 := 0.
  Notation USR2 := 1.

  Section IW_Simple.
    Import IdealWorld.

    Notation perms_CH := 0.
    Notation CH := (Single perms_CH).

    Notation empty_chs := (#0 #+ (CH, [])).

    Definition PERMS := $0 $+ (perms_CH, {| read := true; write := true |}).

    Definition simple_users :=
      [
        (mkiUsr USR1 PERMS
                (
                  n <- Gen
                  ; _ <- Send (Content n) CH
                  ; @Return (Base Nat) n
        ));
        (mkiUsr USR2 PERMS
                ( m <- @Recv Nat CH
                ; @Return (Base Nat) (extractContent m)))
        ].

    Definition simple_univ_start :=
      mkiU empty_chs simple_users.

  End IW_Simple.

  Section IW.
    Import IdealWorld.

    Notation pCH12 := 0.
    Notation pCH21 := 1.
    Notation CH12  := (# pCH12).
    Notation CH21  := (# pCH21).

    Notation empty_chs := (#0 #+ (CH12, []) #+ (CH21, [])).

    Notation PERMS1 := ($0 $+ (pCH12, owner) $+ (pCH21, reader)).
    Notation PERMS2 := ($0 $+ (pCH12, reader) $+ (pCH21, owner)).

    Notation ideal_users :=
      [
        (mkiUsr USR1 PERMS1
                ( chid <- CreateChannel
                  ; _ <- Send (sharePerm chid writer) CH12
                  ; m <- @Recv Access (chid #& pCH21)
                  ; n <- Gen
                  ; _ <- Send (Content n) (getPerm m #& pCH12)
                  ; @Return (Base Nat) n
        )) ;
      (mkiUsr USR2 PERMS2
              ( m <- @Recv Access CH12
                ; chid <- CreateChannel
                ; _ <- Send (sharePerm chid owner) (getPerm m #& pCH21)
                ; m <- @Recv Nat (chid #& pCH12)
                ; @Return (Base Nat) (extractContent m)
      ))
      ].

    Definition ideal_univ_start :=
      mkiU empty_chs ideal_users.

  End IW.

  Section RW.
    Import RealWorld.

    Notation KID1 := 0.
    Notation KID2 := 1.

    Notation KEYS := [ skey KID1 ; skey KID2 ].

    Notation KEYS1 := ($0 $+ (KID1, true) $+ (KID2, false)).
    Notation KEYS2 := ($0 $+ (KID1, false) $+ (KID2, true)).

    Definition real_users :=
      [
        MkRUserSpec USR1 KEYS1
                    ( kp <- GenerateKey AsymKey Encryption
                      ; c1 <- Sign KID1 USR2 (sharePubKey kp)
                      ; _  <- Send USR2 c1
                      ; c2 <- @Recv Access (SignedEncrypted KID2 (fst kp) true)
                      ; m  <- Decrypt c2
                      ; n  <- Gen
                      ; c3 <- SignEncrypt KID1 (getKey m) USR2 (message.Content n)
                      ; _  <- Send USR2 c3
                      ; @Return (Base Nat) n) ;

      MkRUserSpec USR2 KEYS2
                  ( c1 <- @Recv Access (Signed KID1 true)
                    ; v  <- Verify KID1 c1
                    ; kp <- GenerateKey SymKey Encryption
                    ; c2 <- SignEncrypt KID2 (getKey (snd v)) USR1 (sharePrivKey kp)
                    ; _  <- Send USR1 c2
                    ; c3 <- @Recv Nat (SignedEncrypted KID1 (fst kp) true)
                    ; m  <- Decrypt c3
                    ; @Return (Base Nat) (extractContent m) )
      ].

    Definition real_univ_start :=
      mkrU (mkKeys KEYS) real_users.
  End RW.

  #[export] Hint Unfold
       simple_univ_start
       ideal_univ_start
       real_univ_start
    : user_build.

  #[export] Hint Extern 0 (IdealWorld.lstep_universe _ _ _) =>
    progress(autounfold with user_build; simpl) : core.

End ShareSecretSymmetricEncProtocol.


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

(** The RTL intermediate language: abstract syntax and semantics.
  RTL stands for "Register Transfer Language". This is the first
  intermediate language after Cminor and CminorSel.
*)

Require Import Coqlib Maps.
Require Import AST Integers Values Events Memory Globalenvs Smallstep.
Require Import Op Registers RTL.

(** * Abstract syntax *)

(** RTLMach is almost same as RTL, the only difference here is we use
    the memory opration [record_frame_mach] to record new frame instead
    of [record_frame_vm] which is used in all semantics before.
    This new opration calculates only the first framesize of a tailcall
    stage to give the whole stack consumption after a record operation.
    Which is precisely the machine deals with tailcalls.
*)

Section ORACLE.

Variable fn_stack_requirements : ident -> Z.

Section RELSEM.

Variable ge: genv.
(** The transitions are presented as an inductive predicate
  [step ge st1 t st2], where [ge] is the global environment,
  [st1] the initial state, [st2] the final state, and [t] the trace
  of system calls performed during this transition. *)

Inductive step: state -> trace -> state -> Prop :=
  | exec_Inop:
      forall s f sp pc rs m pc',
      (fn_code f)!pc = Some(Inop pc') ->
      step (State s f sp pc rs m)
        E0 (State s f sp pc' rs m)
  | exec_Iop:
      forall s f sp pc rs m op args res pc' v,
      (fn_code f)!pc = Some(Iop op args res pc') ->
      eval_operation ge sp op rs##args m = Some v ->
      step (State s f sp pc rs m)
        E0 (State s f sp pc' (rs#res <- v) m)
  | exec_Iload:
      forall s f sp pc rs m chunk addr args dst pc' a v,
      (fn_code f)!pc = Some(Iload chunk addr args dst pc') ->
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.loadv chunk m a = Some v ->
      step (State s f sp pc rs m)
        E0 (State s f sp pc' (rs#dst <- v) m)
  | exec_Istore:
      forall s f sp pc rs m chunk addr args src pc' a m',
      (fn_code f)!pc = Some(Istore chunk addr args src pc') ->
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.storev chunk m a rs#src = Some m' ->
      step (State s f sp pc rs m)
        E0 (State s f sp pc' rs m')
  | exec_Icall:
      forall s f sp pc rs m sig ros args res pc' fd id,
      ros_is_ident ros rs id ->
      (fn_code f)!pc = Some(Icall sig ros args res pc') ->
      find_function ge ros rs = Some fd ->
      funsig fd = sig ->
      step (State s f sp pc rs m)
        E0 (Callstate (Stackframe res f sp pc' rs :: s) fd rs##args m id)
  | exec_Itailcall:
      forall s f stk pc rs m sig ros args fd m' id m'' m''',
      ros_is_ident ros rs id ->
      (fn_code f)!pc = Some(Itailcall sig ros args) ->
      find_function ge ros rs = Some fd ->
      funsig fd = sig ->
      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
      Mem.return_frame m' = Some m'' ->
      Mem.pop_stage m'' = Some m''' ->
      step (State s f (Vptr stk Ptrofs.zero) pc rs m)
        E0 (Callstate s fd rs##args m''' id)
  | exec_Ibuiltin:
      forall s f sp pc rs m ef args res pc' vargs t vres m',
      (fn_code f)!pc = Some(Ibuiltin ef args res pc') ->
      eval_builtin_args ge (fun r => rs#r) sp m args vargs ->
      external_call ef ge vargs m t vres m' ->
      step (State s f sp pc rs m)
         t (State s f sp pc' (regmap_setres res vres rs) m')
  | exec_Icond:
      forall s f sp pc rs m cond args ifso ifnot b pc',
      (fn_code f)!pc = Some(Icond cond args ifso ifnot) ->
      eval_condition cond rs##args m = Some b ->
      pc' = (if b then ifso else ifnot) ->
      step (State s f sp pc rs m)
        E0 (State s f sp pc' rs m)
  | exec_Ijumptable:
      forall s f sp pc rs m arg tbl n pc',
      (fn_code f)!pc = Some(Ijumptable arg tbl) ->
      rs#arg = Vint n ->
      list_nth_z tbl (Int.unsigned n) = Some pc' ->
      step (State s f sp pc rs m)
        E0 (State s f sp pc' rs m)
  | exec_Ireturn:
      forall s f stk pc rs m or m' m'' m''',
      (fn_code f)!pc = Some(Ireturn or) ->
      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
      Mem.return_frame m' = Some m'' ->
      Mem.pop_stage m'' = Some m''' ->
      step (State s f (Vptr stk Ptrofs.zero) pc rs m)
        E0 (Returnstate s (regmap_optget or Vundef rs) m''')
  | exec_function_internal:
      forall s f args m m' m'' m''' stk id path,
      Mem.alloc_frame m id = (m',path) ->
      Mem.alloc m' 0 f.(fn_stacksize) = (m'', stk) ->
      Mem.record_frame (Mem.push_stage m'')(Memory.mk_frame (fn_stack_requirements id)) = Some m''' ->
      step (Callstate s (Internal f) args m id)
        E0 (State s
                  f
                  (Vptr stk Ptrofs.zero)
                  f.(fn_entrypoint)
                  (init_regs args f.(fn_params))
                  m''')
  | exec_function_external:
      forall s ef args res t m m' sz,
      external_call ef ge args m t res m' ->
      step (Callstate s (External ef) args m sz)
         t (Returnstate s res m')
  | exec_return:
      forall res f sp pc rs s vres m,
      step (Returnstate (Stackframe res f sp pc rs :: s) vres m)
        E0 (State s f sp pc (rs#res <- vres) m).

Lemma exec_Iop':
  forall s f sp pc rs m op args res pc' rs' v,
  (fn_code f)!pc = Some(Iop op args res pc') ->
  eval_operation ge sp op rs##args m = Some v ->
  rs' = (rs#res <- v) ->
  step (State s f sp pc rs m)
    E0 (State s f sp pc' rs' m).
Proof.
  intros. subst rs'. eapply exec_Iop; eauto.
Qed.

Lemma exec_Iload':
  forall s f sp pc rs m chunk addr args dst pc' rs' a v,
  (fn_code f)!pc = Some(Iload chunk addr args dst pc') ->
  eval_addressing ge sp addr rs##args = Some a ->
  Mem.loadv chunk m a = Some v ->
  rs' = (rs#dst <- v) ->
  step (State s f sp pc rs m)
    E0 (State s f sp pc' rs' m).
Proof.
  intros. subst rs'. eapply exec_Iload; eauto.
Qed.

End RELSEM.

(** Execution of whole programs are described as sequences of transitions
  from an initial state to a final state.  An initial state is a [Callstate]
  corresponding to the invocation of the ``main'' function of the program
  without arguments and with an empty call stack. *)

Inductive initial_state (p: program): state -> Prop :=
  | initial_state_intro: forall b f m0 m1 b0,
      let ge := Genv.globalenv p in
      Genv.init_mem p = Some m0 ->
      Genv.find_symbol ge p.(prog_main) = Some b ->
      Genv.find_funct_ptr ge b = Some f ->
      funsig f = signature_main ->
      Mem.alloc m0 0 0 = (m1,b0) ->
      initial_state p (Callstate nil f nil m1 (prog_main p)).

(** A final state is a [Returnstate] with an empty call stack. *)

Inductive final_state: state -> int -> Prop :=
  | final_state_intro: forall r m,
      final_state (Returnstate nil (Vint r) m) r.

(** The small-step semantics for a program. *)

Definition semantics (p: program) :=
  Semantics step (initial_state  p) final_state (Genv.globalenv p).

(** This semantics is receptive to changes in events. *)

Lemma semantics_receptive:
  forall (p: program), receptive (semantics p).
Proof.
  intros. constructor; simpl; intros.
(* receptiveness *)
  assert (t1 = E0 -> exists s2, step (Genv.globalenv p) s t2 s2).
    intros. subst. inv H0. exists s1; auto.
  inversion H; subst; auto.
  exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]].
  exists (State s0 f sp pc' (regmap_setres res vres2 rs) m2). econstructor; eauto.
  exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]].
  exists (Returnstate s0 vres2 m2). econstructor; eauto.
(* trace length *)
  red; intros; inv H; simpl; try lia.
  eapply external_call_trace_length; eauto.
  eapply external_call_trace_length; eauto.
Qed.

(** * Operations on RTL abstract syntax *)

(** Transformation of a RTL function instruction by instruction.
  This applies a given transformation function to all instructions
  of a function and constructs a transformed function from that. *)
End ORACLE.


Require Import VST.sepcomp.semantics.

Require Import VST.veric.Clight_base.
Require Import VST.veric.Clight_core.
Require Import VST.veric.Clight_lemmas.
Require Import VST.sepcomp.step_lemmas.
Require Import VST.sepcomp.event_semantics.
Require Import VST.veric.SeparationLogic.
Require Import VST.veric.juicy_extspec.
Require Import VST.veric.juicy_mem.
Require VST.veric.NullExtension.
(*Require Import VST.veric.Clight_sim.*)
Require Import VST.veric.SeparationLogicSoundness.
Require Import VST.sepcomp.extspec.
Require Import VST.msl.msl_standard.

Import VericSound.
Import VericMinimumSeparationLogic.
Import VericMinimumSeparationLogic.CSHL_Def.
Import VericMinimumSeparationLogic.CSHL_Defs.
Import Clight.

Definition ignores_juice Z (J: external_specification juicy_mem external_function Z) : Prop :=
  (forall e t b tl vl x jm jm',
     m_dry jm = m_dry jm' ->
    ext_spec_pre J e t b tl vl x jm ->
    ext_spec_pre J e t b tl vl x jm') /\
 (forall ef t b ot v x jm jm',
     m_dry jm = m_dry jm' ->
    ext_spec_post J ef t b ot v x jm ->
    ext_spec_post J ef t b ot v x jm') /\
 (forall v x jm jm',
     m_dry jm = m_dry jm' ->
     ext_spec_exit J v x jm ->
     ext_spec_exit J v x jm').

Import VST.veric.compcert_rmaps.R.

Definition mem_evolve (m m': mem) : Prop :=
   (* dry version of resource_decay *)
 forall loc,
 match access_at m loc Cur, access_at m' loc Cur with
 | None, None => True
 | None, Some Freeable => True
 | Some Freeable, None => True
 | Some Writable, Some p' => p' = Writable
 | Some p, Some p' => p=p' /\ access_at m loc Max = access_at m' loc Max
 | _, _ => False
 end.

Instance mem_evolve_refl : RelationClasses.Reflexive mem_evolve.
Proof.
  repeat intro.
  destruct (access_at x loc Cur); auto.
  destruct p; auto.
Qed.

Definition ext_spec_mem_evolve (Z: Type)
  (D: external_specification mem external_function Z) :=
 forall ef w b tl vl ot v z m z' m',
    ext_spec_pre D ef w b tl vl z m ->
    ext_spec_post D ef w b ot v z' m' ->
    mem_evolve m m'.

Definition juicy_dry_ext_spec (Z: Type)
   (J: external_specification juicy_mem external_function Z)
   (D: external_specification mem external_function Z)
   (dessicate: forall ef jm, ext_spec_type J ef -> ext_spec_type D ef) :=
  (forall e t t' b tl vl x jm,
    dessicate e jm t = t' ->
    (ext_spec_pre J e t b tl vl x jm ->
    ext_spec_pre D e t' b tl vl x (m_dry jm))) /\
 (forall ef t t' b ot v x jm0 jm,
    (exists tl vl x0, dessicate ef jm0 t = t' /\ ext_spec_pre J ef t b tl vl x0 jm0) ->
    (level jm <= level jm0)%nat ->
    resource_at (m_phi jm) = resource_fmap (approx (level jm)) (approx (level jm)) oo juicy_mem_lemmas.rebuild_juicy_mem_fmap jm0 (m_dry jm) ->
    ghost_of (m_phi jm) = Some (ghost_PCM.ext_ghost x, compcert_rmaps.RML.R.NoneP) :: ghost_fmap (approx (level jm)) (approx (level jm)) (tl (ghost_of (m_phi jm0))) ->
    (ext_spec_post D ef t' b ot v x (m_dry jm) ->
     ext_spec_post J ef t b ot v x jm)) /\
 (forall v x jm,
     ext_spec_exit J v x jm <->
     ext_spec_exit D v x (m_dry jm)).

Definition juicy_dry_ext_spec_make (Z: Type)
   (J: external_specification juicy_mem external_function Z) :
   external_specification mem external_function Z.
destruct J.
apply Build_external_specification with ext_spec_type.
intros e t b tl vl x m.
apply (forall jm, m_dry jm = m -> (* external ghost matches x -> *) ext_spec_pre e t b tl vl x jm).
intros e t b ot v x m.
apply (forall jm, m_dry jm = m -> ext_spec_post e t b ot v x jm).
intros v x m.
apply (forall jm, m_dry jm = m -> ext_spec_exit v x jm).
Defined.

Definition dessicate_id Z
   (J: external_specification juicy_mem external_function Z) :
   forall ef (jm : juicy_mem), ext_spec_type J ef ->
       ext_spec_type (juicy_dry_ext_spec_make Z J) ef.
intros.
destruct J; simpl in *. apply X.
Defined.

Lemma jdes_make_lemma:
  forall Z J, ignores_juice Z J ->
    juicy_dry_ext_spec Z J (juicy_dry_ext_spec_make Z J)
     (dessicate_id Z J).
Proof.
intros.
destruct H as [? [? ?]], J; split; [ | split3]; simpl in *; intros; auto.
-
subst t'.
eapply H. symmetry; eassumption.  auto.
-
destruct H2 as (? & ? & ? & ? & ?).
subst t'.
eapply H0; auto.
-
eapply H1. symmetry; eassumption. auto.
Qed.

Definition mem_rmap_cohere m phi :=
  contents_cohere m phi /\
  access_cohere m phi /\
  max_access_cohere m phi /\ alloc_cohere m phi.

Lemma age_to_cohere:
 forall m phi n,
    mem_rmap_cohere m phi -> mem_rmap_cohere m (age_to.age_to n phi).
Proof.
intros.
destruct H as [? [? [? ?]]].
split; [ | split3]; hnf; intros.
-
hnf in H.
rewrite age_to_resource_at.age_to_resource_at in H3.
destruct (phi @ loc) eqn:?H; inv H3.
destruct (H _ _ _ _ _ H4); split; subst; auto.
-
rewrite age_to_resource_at.age_to_resource_at .
specialize (H0 loc).
rewrite H0.
destruct (phi @ loc); simpl; auto.
-
rewrite age_to_resource_at.age_to_resource_at .
specialize (H1 loc).
destruct (phi @ loc); simpl; auto.
-
rewrite age_to_resource_at.age_to_resource_at .
specialize (H2 loc H3).
rewrite H2.
reflexivity.
Qed.

Lemma set_ghost_cohere:
 forall m phi g H,
    mem_rmap_cohere m phi ->
   mem_rmap_cohere m (initial_world.set_ghost phi g H).
Proof.
intros.
unfold initial_world.set_ghost.
rename H into Hg. rename H0 into H.
destruct H as [? [? [? ?]]].
split; [ | split3]; hnf; intros.
-
hnf in H.
rewrite resource_at_make_rmap in H3.
destruct (phi @ loc) eqn:?H; inv H3.
destruct (H _ _ _ _ _ H4); split; subst; auto.
-
rewrite resource_at_make_rmap.
specialize (H0 loc).
rewrite H0.
destruct (phi @ loc); simpl; auto.
-
rewrite resource_at_make_rmap.
specialize (H1 loc).
destruct (phi @ loc); simpl; auto.
-
rewrite resource_at_make_rmap.
specialize (H2 loc H3).
rewrite H2.
reflexivity.
Qed.

Lemma mem_evolve_cohere:
  forall jm m' phi',
   mem_evolve (m_dry jm) m' ->
   compcert_rmaps.RML.R.resource_at phi' =
     juicy_mem_lemmas.rebuild_juicy_mem_fmap jm m' ->
   mem_rmap_cohere m' phi'.
Proof.
intros.
destruct jm.
simpl in *.
unfold  juicy_mem_lemmas.rebuild_juicy_mem_fmap in H0.
simpl in H0.
split; [ | split3].
-
hnf; intros; specialize (H loc).
rewrite (JMaccess loc) in *.
rewrite H0 in *; clear H0; simpl in *.
destruct (phi @ loc) eqn:?H.
simpl in H. if_tac in H.
if_tac in H1.
inv H1; auto.
inv H1.
if_tac in H1.
inv H1; auto.
inv H1.
destruct k; simpl in *.
destruct (perm_of_sh sh0) as [[ | | | ] | ] eqn:?H; try contradiction ;auto.
destruct (access_at m' loc Cur) as [[ | | | ] | ]  eqn:?H; try contradiction; try discriminate; auto.
if_tac in H1; inv H1; auto.
if_tac in H1; inv H1; auto.
if_tac in H1; inv H1; auto.
if_tac in H1; inv H1; auto.
if_tac in H1; inv H1; auto.
if_tac in H1; inv H1; auto.
if_tac in H1; inv H1; auto.
inv H1; auto.
inv H1; auto.
inv H1; auto.
-
hnf; intros; specialize (H loc).
rewrite H0; clear H0.
rewrite (JMaccess loc) in *.
destruct (phi @ loc) eqn:?H.
simpl in H. if_tac in H.
destruct (access_at m' loc Cur) as [[ | | | ] | ] eqn:?H; try contradiction; try discriminate; simpl; auto.
unfold perm_of_sh. rewrite if_true by auto. rewrite if_true by auto. auto.
subst. rewrite if_true by auto; auto.
destruct (access_at m' loc Cur) as [[ | | | ] | ] eqn:?H; try contradiction; try discriminate; simpl; auto.
destruct H; discriminate.
destruct H; discriminate.
destruct H; discriminate.
rewrite if_false by auto; auto.
destruct k; simpl in *; auto.
destruct (perm_of_sh sh) as [[ | | | ] | ] eqn:?H; try contradiction ;auto.
destruct (access_at m' loc Cur) as [[ | | | ] | ]  eqn:?H; try solve [contradiction]; try discriminate; auto.
destruct H; discriminate.
destruct H; discriminate.
destruct H; discriminate.
simpl. rewrite if_true; auto.
destruct (access_at m' loc Cur) as [[ | | | ] | ]  eqn:?H; try solve [contradiction]; try discriminate; auto.
destruct (access_at m' loc Cur) as [[ | | | ] | ]  eqn:?H; try solve [contradiction]; try discriminate; auto.
destruct (access_at m' loc Cur) as [[ | | | ] | ]  eqn:?H; try solve [contradiction]; try discriminate; auto.
destruct H; discriminate.
destruct H; discriminate.
destruct H; discriminate.
elimtype False; clear - r H1.
unfold perm_of_sh in H1. if_tac in H1. if_tac in H1; inv H1.
rewrite if_true in H1 by auto. inv H1.
destruct (access_at m' loc Cur) as [[ | | | ] | ]  eqn:?H; try solve [contradiction]; try discriminate; auto.
unfold perm_of_sh in H1. if_tac in H1. if_tac in H1; inv H1.
rewrite if_true in H1 by auto. inv H1.
unfold perm_of_sh in H1. if_tac in H1. if_tac in H1; inv H1.
rewrite if_true in H1 by auto.
inv H1.
destruct (access_at m' loc Cur) as [[ | | | ] | ]  eqn:?H; try solve [contradiction]; try discriminate; auto.
destruct H; discriminate.
destruct H; discriminate.
destruct H; discriminate.
destruct (access_at m' loc Cur) as [[ | | | ] | ]  eqn:?H; try solve [contradiction]; try discriminate; auto.
destruct H; discriminate.
destruct H; discriminate.
destruct H; discriminate.
destruct (access_at m' loc Cur) as [[ | | | ] | ]  eqn:?H; try solve [contradiction]; try discriminate; auto.
simpl in H; destruct H; discriminate.
simpl in H; destruct H; discriminate.
simpl in H; destruct H; discriminate.
-
hnf; intros; specialize (H loc).
rewrite H0; clear H0.
rewrite (JMaccess loc) in *.
destruct (phi @ loc) eqn:?H.
simpl in H. if_tac in H.
destruct (access_at m' loc Cur) as [[ | | | ] | ] eqn:?H; try contradiction; try discriminate; simpl; auto.
eapply perm_order''_trans; [apply access_cur_max | ].
rewrite H2.
unfold perm_of_sh. rewrite if_true by auto. rewrite if_true by auto. constructor.
subst sh. rewrite if_true by auto.
apply po_None.
destruct (access_at m' loc Cur) as [[ | | | ] | ] eqn:?H; try contradiction; try discriminate; simpl; auto.
destruct H; discriminate.
destruct H; discriminate.
destruct H; discriminate.
rewrite if_false by auto.
eapply perm_order''_trans; [apply access_cur_max | ].
rewrite H2. constructor.
destruct k; simpl in *; auto.
destruct (perm_of_sh sh) as [[ | | | ] | ] eqn:?H; try contradiction ;auto.
eapply perm_order''_trans; [apply access_cur_max | ].
destruct (access_at m' loc Cur). destruct H; subst.
match goal with |- Mem.perm_order'' _ ?A =>
  destruct A; try constructor
end.
simpl.
rewrite if_true by auto. auto.
eapply perm_order''_trans; [apply access_cur_max | ].
destruct (access_at m' loc Cur). destruct H; subst.
rewrite if_true. simpl. rewrite H1. apply perm_refl.
clear - r H1.
unfold perm_of_sh in H1.
if_tac in H1. if_tac in H1. inv H1; constructor.
inv H1; constructor.
rewrite if_true in H1 by auto. inv H1; constructor.
contradiction.
eapply perm_order''_trans; [apply access_cur_max | ].
destruct (access_at m' loc Cur). destruct H; subst.
rewrite if_true. simpl. rewrite H1. apply perm_refl.
clear - r H1.
unfold perm_of_sh in H1.
if_tac in H1. if_tac in H1. inv H1; constructor.
inv H1; constructor.
rewrite if_true in H1 by auto. inv H1; constructor.
contradiction.
eapply perm_order''_trans; [apply access_cur_max | ].
destruct (access_at m' loc Cur). destruct H; subst.
rewrite if_true. simpl. rewrite H1. apply perm_refl.
clear - r H1.
unfold perm_of_sh in H1.
if_tac in H1. if_tac in H1. inv H1; constructor.
inv H1; constructor.
rewrite if_true in H1 by auto. inv H1; constructor.
contradiction.
eapply perm_order''_trans; [apply access_cur_max | ].
destruct (access_at m' loc Cur). destruct p0; try contradiction.
match goal with |- Mem.perm_order'' _ ?A =>
  destruct A; try constructor
end.
elimtype False.
clear - H1 r.
unfold perm_of_sh in H1.
if_tac in H1. if_tac in H1. inv H1; constructor.
inv H1; constructor.
rewrite if_true in H1 by auto. inv H1; constructor.
destruct (access_at m' loc Cur); try contradiction.
destruct H; subst p0.
specialize (JMmax_access loc).
rewrite H0 in JMmax_access.
simpl in JMmax_access.
unfold max_access_at in *.
rewrite <- H1. auto.
destruct (access_at m' loc Cur); try contradiction.
destruct H; subst p0.
specialize (JMmax_access loc).
rewrite H0 in JMmax_access.
simpl in JMmax_access.
unfold max_access_at in *.
rewrite <- H1. auto.
simpl in H.
destruct (access_at m' loc Cur); try contradiction.
destruct H; subst.
simpl.
specialize (JMmax_access loc).
rewrite H0 in JMmax_access.
simpl in JMmax_access.
unfold max_access_at in *.
rewrite <- H1. auto.
-
hnf; intros; specialize (H loc).
rewrite H0; clear H0.
specialize (JMalloc loc).
rewrite (JMaccess loc) in *.
destruct (phi @ loc) eqn:?H.
simpl in H. if_tac in H.
destruct loc as [b z].
rewrite nextblock_access_empty in *by auto.
subst.
simpl.
f_equal. apply proof_irr.
destruct loc as [b z].
rewrite nextblock_access_empty in * by auto.
contradiction.
destruct loc as [b z].
rewrite nextblock_access_empty in * by auto.
simpl.
destruct k; auto; try contradiction H.
simpl in H.
destruct loc as [b z].
rewrite nextblock_access_empty in * by auto.
contradiction.
Qed.

Lemma whole_program_sequential_safety_ext:
   forall {CS: compspecs} {Espec: OracleKind} (initial_oracle: OK_ty)
     (EXIT: semax_prog.postcondition_allows_exit Espec tint)
     (dryspec: ext_spec OK_ty)
     (dessicate : forall (ef : external_function) jm,
               ext_spec_type OK_spec ef ->
               ext_spec_type dryspec ef)
     (JDE: juicy_dry_ext_spec _ (@JE_spec OK_ty OK_spec) dryspec dessicate)
     (DME: ext_spec_mem_evolve _ dryspec)
     prog V G m,
     @semax_prog Espec (*NullExtension.Espec*) CS prog initial_oracle V G ->
     Genv.init_mem prog = Some m ->
     exists b, exists q,
       Genv.find_symbol (Genv.globalenv prog) (prog_main prog) = Some b /\
       initial_core  (cl_core_sem (globalenv prog))
           0 m q m (Vptr b Ptrofs.zero) nil /\
       forall n,
        @dry_safeN _ _ _ OK_ty (semax.genv_symb_injective)
            (cl_core_sem (globalenv prog))
            (*(dryspec  OK_ty)*) dryspec
            (Build_genv (Genv.globalenv prog) (prog_comp_env prog))
             n initial_oracle q m.
Proof.
 intros.
 destruct (@semax_prog_rule Espec CS _ _ _ _
     0 (*additional temporary argument - TODO (Santiago): FIXME*)
     initial_oracle EXIT H H0) as [b [q [[H1 H2] H3]]].
 destruct (H3 O) as [jmx [H4x [H5x [H6x [H7x _]]]]].
 destruct (H2 jmx H4x) as [jmx' [H8x H8y]].
 exists b, q. (* , (m_dry jmx'). *)
 split3; auto.
 rewrite H4x in H8y. auto.
 subst. simpl. clear H5x H6x H7x H8y.
 forget (m_dry jmx) as m. clear jmx.
 intro n.
 specialize (H3 n).
 destruct H3 as [jm [? [? [? [? _]]]]].
 unfold semax.jsafeN in H6.
 subst m.
 assert (joins (compcert_rmaps.RML.R.ghost_of (m_phi jm))
   (Some (ghost_PCM.ext_ref initial_oracle, compcert_rmaps.RML.R.NoneP) :: nil)) as J.
 { destruct (compcert_rmaps.RML.R.ghost_of (m_phi jm)); inv H5.
   eexists; constructor; constructor.
   instantiate (1 := (_, _)); constructor; simpl; constructor; auto.
   instantiate (1 := (Some _, _)); repeat constructor; simpl; auto. }
 clear - JDE DME H4 J H6.
  rewrite <- H4 in H6|-*.
 assert (level jm <= n)%nat by lia.
 clear H4; rename H into H4.
 forget initial_oracle as ora.
 revert ora jm q H4 J H6; induction n; simpl; intros.
 assert (level (m_phi jm) = 0%nat) by lia. rewrite H; constructor.
 inv H6.
 - constructor.
 -
   rewrite <- level_juice_level_phi in H4.
   destruct H0 as (?&?&?&Hg).
   eapply safeN_step.
   + red. red. fold (globalenv prog). eassumption.
   + destruct (H1 (Some (ghost_PCM.ext_ref ora, compcert_rmaps.RML.R.NoneP) :: nil)) as (m'' & J'' & (? & ? & ?) & ?); auto.
     { eexists; apply join_comm, core_unit. }
     { rewrite Hg.
       destruct J; eexists; apply compcert_rmaps.RML.ghost_fmap_join; eauto. }
     replace (m_dry m') with (m_dry m'') by auto.
     change (level (m_phi jm)) with (level jm) in *.
     replace n0 with (level m'') by lia.
     apply IHn; auto. lia.
     replace (level m'') with n0 by lia. auto.
 -
   destruct dryspec as [ty pre post exit]. simpl in *. (* subst ty. *)
   destruct JE_spec as [ty' pre' post' exit']. simpl in *.
   change (level (m_phi jm)) with (level jm) in *.
   destruct JDE as [JDE1 [JDE2 JDE3]].
   specialize (JDE1 e x (dessicate e jm x)); simpl in JDE1.
   eapply safeN_external.
     eassumption.
     apply JDE1. reflexivity. assumption.
     simpl. intros.
     assert (H20: exists jm', m_dry jm' = m'
                      /\ (level jm' = n')%nat
                      /\ juicy_safety.pures_eq (m_phi jm) (m_phi jm')
                      /\ resource_at (m_phi jm') = resource_fmap (approx (level jm')) (approx (level jm')) oo juicy_mem_lemmas.rebuild_juicy_mem_fmap jm (m_dry jm')
                      /\ compcert_rmaps.RML.R.ghost_of (m_phi jm') = Some (ghost_PCM.ext_ghost z', compcert_rmaps.RML.R.NoneP) :: ghost_fmap (approx (level jm')) (approx (level jm')) (tl (ghost_of (m_phi jm)))). {
     destruct (juicy_mem_lemmas.rebuild_juicy_mem_rmap jm m')
            as [phi [? [? ?]]].
     assert (own.ghost_approx phi (Some (ghost_PCM.ext_ghost z', NoneP) :: tl (compcert_rmaps.RML.R.ghost_of phi)) =
        Some (ghost_PCM.ext_ghost z', NoneP) :: tl (compcert_rmaps.RML.R.ghost_of phi)) as Happrox.
     { simpl; f_equal.
        rewrite <- compcert_rmaps.RML.ghost_of_approx at 2.
        destruct (compcert_rmaps.RML.R.ghost_of phi); auto. }
     set (phi1 := initial_world.set_ghost _ _ Happrox).
     assert (level phi1 = level phi /\ resource_at phi1 = resource_at phi) as [Hl1 Hr1].
     { subst phi1; unfold initial_world.set_ghost; rewrite level_make_rmap, resource_at_make_rmap; auto. }
     pose (phi' := age_to.age_to n' phi1).
     assert (mem_rmap_cohere m' phi'). {
       clear - H1 Hr1 Hl1 H8 H7 H6 H3 DME JDE1.
       apply JDE1 in H1; [ | reflexivity].
       specialize (DME e _ _ _ _ _ _ _ _ _ _ H1 H6).
     subst phi'.
     apply age_to_cohere.
     subst phi1.
     apply set_ghost_cohere.
     eapply mem_evolve_cohere; eauto.
   }
    destruct H10 as [H10 [H11 [H12 H13]]].
     pose (jm' := mkJuicyMem _ _ H10 H11 H12 H13).
     exists jm'.
     split; [ | split3].
     subst jm'; simpl; auto.
     subst jm' phi'; simpl. apply age_to.level_age_to. lia.
     hnf. split. intro loc. subst jm' phi'. simpl.
     rewrite age_to_resource_at.age_to_resource_at.
     rewrite Hr1, H8. unfold juicy_mem_lemmas.rebuild_juicy_mem_fmap.
     destruct (m_phi jm @ loc); auto. rewrite age_to.level_age_to by lia.
      reflexivity.
     intro loc. subst jm' phi'. simpl.
     rewrite age_to_resource_at.age_to_resource_at.
     rewrite Hr1, H8. unfold juicy_mem_lemmas.rebuild_juicy_mem_fmap; simpl.
     destruct (m_phi jm @ loc); auto.
     if_tac; simpl; auto. destruct k; simpl; auto. if_tac; simpl; eauto. simpl; eauto.
     subst jm' phi'. simpl m_phi.
     rewrite age_to_resource_at.age_to_ghost_of.
     subst phi1.
     split.
     extensionality; unfold compose; simpl.
     rewrite age_to_resource_at.age_to_resource_at, age_to.level_age_to by lia.
     unfold initial_world.set_ghost; rewrite resource_at_make_rmap.
     rewrite H8; auto.
     unfold initial_world.set_ghost; rewrite ghost_of_make_rmap; simpl.
     rewrite age_to.level_age_to, H9 by (rewrite level_make_rmap; lia); simpl; auto.
   }
   destruct H20 as [jm'  [H26 [H27 [H28 [H29 Hg']]]]].
   specialize (H2 ret jm' z' n' Hargsty Hretty).
   spec H2. lia.
    spec H2. hnf; split3; auto. lia.
  spec H2.
  eapply JDE2; eauto 6. lia. subst m'. apply H6.
  destruct H2 as [c' [H2a H2b]]; exists c'; split; auto.
  hnf in H2b.
  specialize (H2b (Some (ghost_PCM.ext_ref z', compcert_rmaps.RML.R.NoneP) :: nil)).
  spec H2b. apply join_sub_refl.
  spec H2b.
  { rewrite Hg'.
    eexists (Some (ghost_PCM.ext_both z', compcert_rmaps.RML.R.NoneP) :: _);
      repeat constructor.  }
  destruct H2b as [jm'' [? [? ?]]].
  destruct H7 as [? [? ?]].
  subst m'. rewrite <- H7.
  specialize (IHn  z' jm'' c').
  subst n'. rewrite <- H9.
  change (level (m_phi jm'')) with (level  jm'') in IHn.
  apply IHn. lia.
  auto.
  rewrite H9; auto.
 - eapply safeN_halted; eauto.
    apply JDE. auto.
 Unshelve. simpl. split; [apply Share.nontrivial | hnf]. exists None; constructor.
Qed.

Require Import VST.veric.juicy_safety.

Definition fun_id (ext_link: Strings.String.string -> ident) (ef: external_function) : option ident :=
  match ef with EF_external id sig => Some (ext_link id) | _ => None end.


Require Import CertiGraph.lib.Coqlib.
Require Export VST.floyd.proofauto.
Require Import CertiGraph.mark.env_mark_bi.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.GraphBi.
Require Import CertiGraph.msl_application.Graph_Mark.
Require Import CertiGraph.msl_application.DagBi_Mark.
Require Import CertiGraph.floyd_ext.share.
Require Import CertiGraph.mark.spatial_graph_bi_mark.
Require Import VST.msl.wand_frame.
Require Import VST.floyd.reassoc_seq.
Require Import VST.floyd.field_at_wand.

Local Coercion Graph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

(* Using unit for DE and DG, inspired by Graph *)
Notation dag sh x g := (@reachable_dag_vertices_at _ _ _ _ _ _ unit unit _ mpred (@SGP pSGG_VST bool unit (sSGG_VST sh)) (SGA_VST sh) x g).
Notation Graph := (@Graph pSGG_VST bool unit unit).
Existing Instances MGS biGraph maGraph finGraph RGF.

Definition mark_spec :=
 DECLARE _mark
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [tptr (Tstruct _Node noattr)]
          PROP  (weak_valid g x)
          PARAMS (pointer_val_val x)
          GLOBALS ()
          SEP   (dag sh x g)
  POST [ Tvoid ]
      EX g': Graph,
        PROP (mark x g g')
        LOCAL()
        SEP (dag sh x g').

Definition main_spec :=
 DECLARE _main
  WITH u : globals
  PRE  [] main_pre prog tt u
  POST [ tint ] main_post prog u.

Definition Gprog : funspecs := ltac:(with_library prog [mark_spec ; main_spec]).

Lemma dag_local_facts: forall sh x (g: Graph), weak_valid g x -> dag sh x g |-- valid_pointer (pointer_val_val x).
Proof.
  intros. destruct H.
  - simpl in H. subst x. entailer!.
  - destruct (vgamma g x) as [[d l] r] eqn:?.
    pose proof (@root_unfold _ (sSGG_VST sh) g x d l r H Heqp); clear -H0.
    simpl in *. rewrite H0. entailer!.
Qed.

Lemma body_mark: semax_body Vprog Gprog f_mark mark_spec.
Proof.
  start_function.
  remember (vgamma g x) as dlr eqn:?H.
  destruct dlr as [[d l] r].
  rename H0 into H_GAMMA_g; symmetry in H_GAMMA_g.
  rename H into H_weak_valid.

  forward_if  (* if (x == 0) *)
    (PROP  (pointer_val_val x <> nullval)
     LOCAL (temp _x (pointer_val_val x))
     SEP   (dag sh x g)).
  - apply denote_tc_test_eq_split. 2: entailer!. apply dag_local_facts; auto.
  - (* return *) forward. Exists g. entailer!. destruct x. 1: simpl in H; inversion H. apply (mark_null_refl g).
  - (* skip *) forward. entailer!.
  - Intros. assert (vvalid g x) as gx_vvalid. {
      destruct H_weak_valid; [| auto].
      unfold is_null_SGBA in H0; simpl in H0; subst x.
      exfalso. apply H. auto.
    } assert (isptr (pointer_val_val x) /\ exists b i, x = ValidPointer b i). {
      destruct x. 2: exfalso; apply H; reflexivity. split; simpl; auto.
      exists b, i. reflexivity.
    } destruct H0 as [? [b [i ?]]]. clear H0 H_weak_valid.
    pose proof (@root_unfold _ (sSGG_VST sh) g x d l r gx_vvalid).
    simpl in H0. simpl reachable_dag_vertices_at.
    erewrite H0 by eauto. Intros.
    change (vertex_at x (d, l, r)) with
        (@data_at CompSpecs sh node_type
                  (Vint (Int.repr (if d then 1 else 0)), (pointer_val_val l, pointer_val_val r)) (pointer_val_val x)).
    forward. (* root_mark = x -> m; *)
    eapply semax_pre with
        (PROP  ()
               LOCAL
               (temp _root_mark (Vint (Int.repr (if d then 1 else 0)));
                temp _x (pointer_val_val x))
               SEP  (dag sh x g)).
    1: { pose proof (@root_unfold _ (sSGG_VST sh) g x d l r gx_vvalid).
         simpl in H2. simpl reachable_dag_vertices_at.
         erewrite H2 by eauto; simpl vertex_at; entailer!.
         }
    forward_if  (* if (root_mark == 1) *)
      (PROP (d = false)
            LOCAL (temp _x (pointer_val_val x))
            SEP (dag sh x g)).
    + forward. (* return *) Exists g. entailer!.
      eapply (mark_vgamma_true_refl g); eauto.
      now destruct d.
    + forward. (* skip; *) entailer!.
      now destruct d.
    +
      pose proof (@root_unfold _ (sSGG_VST sh) g x d l r gx_vvalid).
      simpl in H2. simpl reachable_dag_vertices_at.
      erewrite H2 by eauto.
      Intros. subst d.
      change (vertex_at x (false, l, r)) with
          (@data_at CompSpecs sh node_type
                    (Vint (Int.repr 0), (pointer_val_val l, pointer_val_val r)) (pointer_val_val x)).
      forward. (* l = x -> l; *) 1: entailer!; destruct l; simpl; auto.
      forward. (* r = x -> r; *) 1: entailer!; destruct r; simpl; auto.
      forward. (* x -> d = 1; *)
      pose proof Graph_vgen_true_mark1 g x _ _ H_GAMMA_g gx_vvalid.
      apply semax_pre with
          (PROP  ()
                 LOCAL (temp _r (pointer_val_val r);
                        temp _l (pointer_val_val l);
                        temp _x (pointer_val_val x))
                 SEP (dag sh x (Graph_vgen g x true))).
      1: { pose proof (@root_update_unfold _ (sSGG_VST sh) g).
           simpl in H4. simpl reachable_dag_vertices_at.
           erewrite H4 by eauto; simpl vertex_at; entailer!. }
           forget (Graph_vgen g x true) as g1.
      assert (weak_valid g1 l) by (eapply left_weak_valid; eauto).
      (* mark(l); *)
      localize [dag sh l g1].
      forward_call (sh, g1, l).
      Intros g2.
      unlocalize [dag sh x g2] using g2 assuming H5.
      1: { subst.
           pose proof (@dag_ramify_left _ (sSGG_VST sh) g g1 (ValidPointer b i) l r gx_vvalid H_GAMMA_g H3).
           simpl reachable_dag_vertices_at in *.
           eapply H1.
      }
       assert (weak_valid g2 r) by (eapply right_weak_valid; eauto).
      (* mark(r); *)
      localize [dag sh r g2].
      forward_call (sh, g2, r).
      Intros g3.
      unlocalize [dag sh x g3] using g3 assuming H7.
      1: { subst.
           pose proof (@dag_ramify_right _ (sSGG_VST sh) g
                         _ _ _ _ _ gx_vvalid H_GAMMA_g H3 H5).
           simpl reachable_dag_vertices_at in *; eapply H1.
           }
      (* ( return; ) *)
      Exists g3. entailer!.
      apply (mark1_mark_left_mark_right g g1 g2 g3 (ValidPointer b i) l r); auto.
Qed. (* Original: 114 seconds; VST 2.*: 2.739 secs *)


From ITree Require Import
     Subevent
     Indexed.Sum.

From CTree Require Import
     CTree
     Interp.Interp
     Equ
     SBisim
     Core.Utils.

From ExtLib Require Import
     Monad
     Traversable
     RelDec.

From Coq Require Import
     Vector
     Fin (* fin definition here *)
     Program.Equality
     Program.Basics
     Classes.Morphisms
     Classes.RelationClasses
     Lia.

From Equations Require Import
     Equations.

From DSL Require Import
     System
     Utils
     Vectors
     Ltac.

From Coinduction Require Import
     rel coinduction tactics.

Import EquNotations.
Import MonadNotation.
Import ProperNotations.
Import SBisimNotations.

Local Open Scope monad_scope.
Local Open Scope vector_scope.
Local Open Scope fin_vector_scope.

Set Implicit Arguments.
Set Contextual Implicit.

(** Network *)
Module Network(S: Systems).
  Module Messaging := Messaging(S).
  Module Storage := Storage(S).
  Export Monads Storage Messaging S.

  Notation InitSys n E R := (vec n (ctree E R)) (only parsing).
  Notation Sys n E R := (vec n (Task n E R)) (only parsing).
  Notation SysLeaf n R := (option (vec n (R * queue n))) (only parsing).
  Notation SysTree n E R := (ctree E (SysLeaf n R)) (only parsing).

  Equations get_running{E A m n}(v: vec m (Task n E A))
            (i: fin (num_running v)): (fin m * ctree E A * queue n) :=
    get_running ((Running _ _) :: ts) (FS k) :=
      let '(i, a, q) := get_running ts k in (FS i, a, q);
    get_running ((Done _ _) :: ts) k :=
      let '(i, a, q) := get_running ts k in (FS i, a, q);
    get_running ((Blocked _ _) :: ts) k :=
      let '(i, a, q) := get_running ts k in (FS i, a, q);
    get_running ((Running a q) :: ts) F1 := (F1, a ,q).

  (** Blocking processes might cause a deadlock, in which case we return 'None'
      or `Some (vec n _)` (every agent returned)
   *)
  Equations schedule_network_0 {E A m n} (a: vec m (Task n E A))
            (H: num_running a = 0): option (vec m (A * queue n)) :=
    schedule_network_0 [] _ := Some [];
    schedule_network_0 ((Done r q)::ts) _ :=
      option_map (fun l => (r, q) :: l) (schedule_network_0 ts _);
    schedule_network_0 ((Blocked _ _)::ts) _ := None.

  Equations schedule_one{R: Type}{E: Type -> Type}{n: nat}
            (schedule: Sys n (Net n +' E) R -> SysTree n E R)
            (sys: Sys n (Net n +' E) R)
            (r: fin (num_running sys)) : SysTree n E R :=
    schedule_one schedule sys r with get_running sys r => {
        schedule_one _ _ _ (i, a, q) with observe a => {
          (** Returns a value *)
          schedule_one _ _ _ _ (RetF v) :=
            TauI (schedule (sys @ i := Done v q));

          (** A previous choice, traverse it *)
          schedule_one _ _ _ _ (ChoiceF b n' k) :=
            Choice b n' (fun i' => schedule (sys @ i := Running (k i') q));

          (** A network `send` effect, interpet it! *)
          schedule_one _ _ _ _ (VisF (inl1 (Send m)) k) with (sys $ principal m)=>{
            (** Deliver to running *)
            schedule_one _ _ _ (i, _, _) _ (Running c q) :=
              let msg' := {| principal := i; payload := payload m |} in
              let sys' := sys @ i := Running (k tt) q in
              let recp := principal m in
              TauI (schedule (sys' @ recp := Running c (List.cons msg' q)));

            (** Deliver to blocked processes and unblock them *)
            schedule_one _ _ _ (i, _, _) _ (Blocked c q) :=
              let msg' := {| principal := i; payload := payload m |} in
              let sys' := sys @ i := Running (k tt) q in
              let recp := principal m in
              TauI (schedule (sys' @ recp := Running c (List.cons msg' q)));

            (** Do not deliver to Done processes *)
            schedule_one _ _ _ (i, _, _) _ (Done _ _) :=
            TauI (schedule (sys @ i := Running (k tt) q))
          };

          (** Receive a message *)
          schedule_one _ _ _ _ (VisF (inl1 Recv) k) with last q => {
            (** Pop the msg from the end *)
            schedule_one _ _ _ (i, _, _) _ (Some msg) :=
              TauI (schedule (sys @ i := Running (k msg) (init q)));
            (** Becomes blocked if no messages in q *)
            schedule_one _ _ _ (i, _, _) _ None :=
              TauI (schedule (sys @ i := Blocked a q))
          };

          (** Broadcast a message to everyone *)
          schedule_one _ _ _ _ (VisF (inl1 (Broadcast b)) k) :=
            let msg := {| principal := i; payload := b |} in
            let sys' := map (fun a => match a with
                                      | Running a q => Running a (List.cons msg q)
                                      | Done a q => Done a q
                                      | Blocked a q => Running a (List.cons msg q)
                                      end) sys in
            TauI (schedule (sys' @ i := Running (k tt) q));

          (** Some other downstream effect *)
          schedule_one _ _ _ _ (VisF (inr1 e) k) :=
            TauI (schedule (sys @ i := Running (trigger e >>= k) q))
        }
      }.
  (** TODO: NON-det version
      sys'' <- mapT (fun a: list Msg * itree Net R =>
      let (q', a') := a in
      CTrees.choiceV2
      (CTrees.Ret (msg :: q', a'))
      (CTrees.Ret (q', a'))) sys';;

      CTrees.TauV (schedule sys'' done)
   *)

  Definition schedule_network{R: Type}{E}{n: nat}
             (schedule: Sys n (Net n +' E) R -> SysTree n E R)
             (sys: Sys n (Net n +' E) R): SysTree n E R :=
    match num_running sys as n1 return
          (num_running sys = n1 -> SysTree n E R) with
    | 0 => fun Hnr: num_running sys = 0 =>
             Ret (schedule_network_0 sys Hnr)
    | S n1 => fun Hnr: num_running sys = S n1 =>
                r <- choice false (num_running sys) ;;
                schedule_one schedule sys r
    end eq_refl.

  CoFixpoint schedule {R: Type}{E: Type -> Type}{n: nat} :=
    @schedule_network R E n schedule.

  Lemma rewrite_schedule: forall n R E (s: Sys n (Net n +' E) R),
      schedule s ≅ schedule_network schedule s.
  Proof.
    intros.
    __step_equ.
    eauto.
  Qed.

  Typeclasses eauto := 6.

  Transparent schedule.
  Transparent schedule_one.
  Transparent schedule_network_0.
  Transparent get_running.
  Transparent vector_replace.

  (** Evaluates Net *)
  Definition run_network{E R n} (s: InitSys n (Net n +' E) R): SysTree n E R :=
    schedule (Vector.map (fun it => Running it List.nil) s).

  #[global] Instance sbisim_clos_network_goal{n E R}:
    Proper (sbisim ==> eq ==> sbisim) (fun h ts => @run_network E R (S n) (h :: ts)).
  Proof.
    unfold Proper, respectful, run_network.
    intros x y Hxy nx ny Hn.
    cbn.
    remember (map (fun it : ctree (Net (S n) +' E) R => Running it Datatypes.nil) nx) as netx.
    remember (map (fun it : ctree (Net (S n) +' E) R => Running it Datatypes.nil) ny) as nety.
    eapply transitivity with (y:=schedule_one schedule (Running x List.nil :: netx) (F1)); cbn.
    - desobs x.
      cbn.
  Admitted.

End Network.


Require Import Eqdep_dec Arith Omega List ListUtils Rounding Psatz.
Require Import Word WordAuto AsyncDisk Pred PredCrash GenSepN Array SepAuto.
Require Import Rec Prog BasicProg Hoare RecArrayUtils Log.
Require Import FMapAVL FMapMem.
Require Import MapUtils.
Require Import Structures.OrderedType.
Require Import Structures.OrderedTypeEx.
Import ListNotations.

Set Implicit Arguments.

Module LogRecArray (RA : RASig).

  Module Defs := RADefs RA.
  Import RA Defs.

  Definition items_valid xp (items : itemlist) :=
    xparams_ok xp /\ RAStart xp <> 0 /\
    length items = (RALen xp) * items_per_val /\
    Forall Rec.well_formed items.

  (** rep invariant *)
  Definition rep xp (items : itemlist) :=
    ( exists vl, [[ vl = ipack items ]] *
      [[ items_valid xp items ]] *
      arrayN (@ptsto _ addr_eq_dec valuset) (RAStart xp) (synced_list vl))%pred.

  Definition get lxp xp ix ms :=
    let '(bn, off) := (ix / items_per_val, ix mod items_per_val) in
    let^ (ms, v) <- LOG.read_array lxp (RAStart xp) bn ms;
    Ret ^(ms, selN_val2block v off).

  Definition put lxp xp ix item ms :=
    let '(bn, off) := (ix / items_per_val, ix mod items_per_val) in
    let^ (ms, v) <- LOG.read_array lxp (RAStart xp) bn ms;
    let v' := block2val_updN_val2block v off item in
    ms <- LOG.write_array lxp (RAStart xp) bn v' ms;
    Ret ms.

  (** read n blocks starting from the beginning *)
  Definition read lxp xp nblocks ms :=
    let^ (ms, r) <- LOG.read_range lxp (RAStart xp) nblocks iunpack nil ms;
    Ret ^(ms, r).

  (** write all items starting from the beginning *)
  Definition write lxp xp items ms :=
    ms <- LOG.write_range lxp (RAStart xp) (ipack items) ms;
    Ret ms.

  (** set all items to item0 *)
  Definition init lxp xp ms :=
    ms <- LOG.write_range lxp (RAStart xp) (repeat $0 (RALen xp)) ms;
    Ret ms.

  (* find the first item that satisfies cond *)
  Definition ifind lxp xp (cond : item -> addr -> bool) ms :=
    let^ (ms, ret) <- ForN i < (RALen xp)
    Hashmap hm
    Ghost [ F m xp items Fm crash sm m1 m2 ]
    Loopvar [ ms ret ]
    Invariant
    LOG.rep lxp F (LOG.ActiveTxn m1 m2) ms sm hm *
                              [[[ m ::: Fm * rep xp items ]]] *
                              [[ forall st,
                                   ret = Some st ->
                                   cond (snd st) (fst st) = true
                                   /\ (fst st) < length items
                                   /\ snd st = selN items (fst st) item0 ]]
    OnCrash  crash
    Begin
      If (is_some ret) {
        Ret ^(ms, ret)
      } else {
        let^ (ms, v) <- LOG.read_array lxp (RAStart xp) i ms;
        let r := ifind_block cond (val2block v) (i * items_per_val) in
        match r with
        (* loop call *)
        | None => Ret ^(ms, None)
        (* break *)
        | Some ifs => Ret ^(ms, Some ifs)
        end
      }
    Rof ^(ms, None);
    Ret ^(ms, ret).

  Local Hint Resolve items_per_val_not_0 items_per_val_gt_0 items_per_val_gt_0'.

  Lemma items_valid_updN : forall xp items a v,
    items_valid xp items ->
    Rec.well_formed v ->
    items_valid xp (updN items a v).
  Proof.
    unfold items_valid; intuition.
    rewrite length_updN; auto.
    apply Forall_wellformed_updN; auto.
  Qed.

  Lemma items_valid_upd_range : forall xp items len a v,
    items_valid xp items ->
    Rec.well_formed v ->
    items_valid xp (upd_range items a len v).
  Proof.
    induction len; simpl; intros; auto using items_valid_updN.
  Qed.

  Lemma ifind_length_ok : forall xp i items,
    i < RALen xp ->
    items_valid xp items ->
    i < length (synced_list (ipack items)).
  Proof.
    unfold items_valid; intuition.
    eapply synced_list_ipack_length_ok; eauto.
  Qed.

  Lemma items_valid_length_eq : forall xp a b,
    items_valid xp a ->
    items_valid xp b ->
    length (ipack a) = length (ipack b).
  Proof.
    unfold items_valid; intuition.
    eapply ipack_length_eq; eauto.
  Qed.

  Theorem get_ok : forall lxp xp ix ms,
    {< F Fm m0 sm m items,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[ ix < length items ]] *
          [[[ m ::: Fm * rep xp items ]]]
    POST:hm' RET:^(ms', r)
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm' *
          [[ r = selN items ix item0 ]]
    CRASH:hm' exists ms',
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm'
    >} get lxp xp ix ms.
  Proof.
    unfold get, rep.
    safestep.
    rewrite synced_list_length, ipack_length.
    apply div_lt_divup; auto.

    safestep.
    subst; rewrite synced_list_selN; simpl.
    erewrite selN_val2block_equiv.
    apply ipack_selN_divmod; auto.
    apply list_chunk_wellformed; auto.
    unfold items_valid in *; intuition; auto.
    apply Nat.mod_upper_bound; auto.
  Qed.

  Theorem put_ok : forall lxp xp ix e ms,
    {< F Fm m0 sm m items,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[ ix < length items /\ Rec.well_formed e ]] *
          [[[ m ::: Fm * rep xp items ]]]
    POST:hm' RET:ms' exists m',
          LOG.rep lxp F (LOG.ActiveTxn m0 m') ms' sm hm' *
          [[[ m' ::: Fm * rep xp (updN items ix e) ]]]
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} put lxp xp ix e ms.
  Proof.
    unfold put, rep.
    hoare; subst.

    (* [rewrite block2val_updN_val2block_equiv] somewhere *)

    rewrite synced_list_length, ipack_length; apply div_lt_divup; auto.
    rewrite synced_list_length, ipack_length; apply div_lt_divup; auto.
    unfold items_valid in *; intuition auto.

    apply arrayN_unify.
    rewrite synced_list_selN, synced_list_updN; f_equal; simpl.
    rewrite block2val_updN_val2block_equiv.
    apply ipack_updN_divmod; auto.
    apply list_chunk_wellformed.
    unfold items_valid in *; intuition; auto.
    apply Nat.mod_upper_bound; auto.
    apply items_valid_updN; auto.
  Qed.

  Theorem read_ok : forall lxp xp nblocks ms,
    {< F Fm m0 sm m items,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[ nblocks <= RALen xp ]] *
          [[[ m ::: Fm * rep xp items ]]]
    POST:hm' RET:^(ms', r)
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm' *
          [[ r = firstn (nblocks * items_per_val) items ]]
    CRASH:hm' exists ms',
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm'
    >} read lxp xp nblocks ms.
  Proof.
    unfold read, rep.
    hoare.

    rewrite synced_list_length, ipack_length.
    unfold items_valid in *; intuition.
    substl (length items); rewrite divup_mul; auto.

    subst; rewrite synced_list_map_fst.
    unfold items_valid in *; intuition.
    eapply iunpack_ipack_firstn; eauto.
  Qed.

  Theorem write_ok : forall lxp xp items ms,
    {< F Fm m0 sm m old,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[ items_valid xp items ]] *
          [[[ m ::: Fm * rep xp old ]]]
    POST:hm' RET:ms' exists m',
          LOG.rep lxp F (LOG.ActiveTxn m0 m') ms' sm hm' *
          [[[ m' ::: Fm * rep xp items ]]]
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} write lxp xp items ms.
  Proof.
    unfold write, rep.
    hoare.

    unfold items_valid in *; intuition; auto.
    erewrite synced_list_length, items_valid_length_eq; eauto.
    rewrite vsupsyn_range_synced_list; auto.
    erewrite synced_list_length, items_valid_length_eq; eauto.
  Qed.

  Theorem init_ok : forall lxp xp ms,
    {< F Fm m0 sm m vsl,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[ xparams_ok xp /\ RAStart xp <> 0 /\ length vsl = RALen xp ]] *
          [[[ m ::: Fm * arrayN (@ptsto _ addr_eq_dec _) (RAStart xp) vsl ]]]
    POST:hm' RET:ms' exists m',
          LOG.rep lxp F (LOG.ActiveTxn m0 m') ms' sm hm' *
          [[[ m' ::: Fm * rep xp (repeat item0 ((RALen xp) * items_per_val) ) ]]]
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} init lxp xp ms.
  Proof.
    unfold init, rep.
    hoare.

    rewrite repeat_length; omega.
    rewrite vsupsyn_range_synced_list by (rewrite repeat_length; auto).
    apply arrayN_unify; f_equal.
    apply repeat_ipack_item0.

    unfold items_valid; intuition.
    rewrite repeat_length; auto.
    apply Forall_repeat.
    apply item0_wellformed.
  Qed.

  Hint Extern 0 (okToUnify (LOG.arrayP (RAStart _) _) (LOG.arrayP (RAStart _) _)) =>
  constructor : okToUnify.

  Hint Resolve
       ifind_list_ok_cond
       ifind_result_inbound
       ifind_result_item_ok.

  Theorem ifind_ok : forall lxp xp cond ms,
    {< F Fm m0 sm m items,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[[ m ::: Fm * rep xp items ]]]
    POST:hm' RET:^(ms', r)
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm' *
        ( [[ r = None ]] \/ exists st,
          [[ r = Some st /\ cond (snd st) (fst st) = true
                         /\ (fst st) < length items
                         /\ snd st = selN items (fst st) item0 ]])
    CRASH:hm' exists ms',
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm'
    >} ifind lxp xp cond ms.
  Proof.
    unfold ifind, rep.
    safestep. eauto.
    eassign items.
    pred_apply_instantiate; cancel.
    eauto.

    safestep.
    safestep.
    safestep.
    eapply ifind_length_ok; eauto.

    unfold items_valid in *; intuition idtac.
    step.
    cancel.

    safestep.
    destruct a; cancel.
    match goal with
    | [ H: forall _, Some _ = Some _ -> _ |- _ ] =>
      edestruct H; eauto
    end.
    or_r; cancel.
    pimpl_crash.
    eassign (exists ms', LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm)%pred.
    cancel.
    erewrite LOG.rep_hashmap_subset; eauto.

    Unshelve. exact tt.
  Qed.

  Hint Extern 1 ({{_}} Bind (get _ _ _ _) _) => apply get_ok : prog.
  Hint Extern 1 ({{_}} Bind (put _ _ _ _ _) _) => apply put_ok : prog.
  Hint Extern 1 ({{_}} Bind (read _ _ _ _) _) => apply read_ok : prog.
  Hint Extern 1 ({{_}} Bind (write _ _ _ _) _) => apply write_ok : prog.
  Hint Extern 1 ({{_}} Bind (init _ _ _) _) => apply init_ok : prog.
  Hint Extern 1 ({{_}} Bind (ifind _ _ _ _) _) => apply ifind_ok : prog.

  (** operations using array spec *)

  Definition get_array lxp xp ix ms :=
    r <- get lxp xp ix ms;
    Ret r.

  Definition put_array lxp xp ix item ms :=
    r <- put lxp xp ix item ms;
    Ret r.

  Definition read_array lxp xp nblocks ms :=
    r <- read lxp xp nblocks ms;
    Ret r.

  Definition ifind_array lxp xp cond ms :=
    r <- ifind lxp xp cond ms;
    Ret r.

  Theorem get_array_ok : forall lxp xp ix ms,
    {< F Fm Fi m0 sm m items e,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[[ m ::: Fm * rep xp items ]]] *
          [[[ items ::: Fi * (ix |-> e) ]]]
    POST:hm' RET:^(ms', r)
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm' * [[ r = e ]]
    CRASH:hm' exists ms',
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm'
    >} get_array lxp xp ix ms.
  Proof.
    unfold get_array.
    hoare.
    eapply list2nmem_ptsto_bound; eauto.
    subst; apply eq_sym.
    eapply list2nmem_sel; eauto.
  Qed.

  Theorem put_array_ok : forall lxp xp ix e ms,
    {< F Fm Fi m0 sm m items e0,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[ Rec.well_formed e ]] *
          [[[ m ::: Fm * rep xp items ]]] *
          [[[ items ::: Fi * (ix |-> e0) ]]]
    POST:hm' RET:ms' exists m' items',
          LOG.rep lxp F (LOG.ActiveTxn m0 m') ms' sm hm' *
          [[ items' = updN items ix e ]] *
          [[[ m' ::: Fm * rep xp items' ]]] *
          [[[ items' ::: Fi * (ix |-> e) ]]]
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} put_array lxp xp ix e ms.
  Proof.
    unfold put_array.
    hoare.
    eapply list2nmem_ptsto_bound; eauto.
    eapply list2nmem_updN; eauto.
  Qed.

  Lemma read_array_length_ok : forall l xp Fm Fi m items nblocks,
    length l = nblocks * items_per_val ->
    (Fm * rep xp items)%pred (list2nmem m) ->
    (Fi * arrayN (@ptsto _ addr_eq_dec _) 0 l)%pred (list2nmem items) ->
    nblocks <= RALen xp.
  Proof.
    unfold rep; intuition.
    destruct_lift H0.
    unfold items_valid in *; subst; intuition.
    apply list2nmem_arrayN_length in H1.
    rewrite H, H3 in H1.
    eapply Nat.mul_le_mono_pos_r.
    apply items_per_val_gt_0.
    auto.
  Qed.

  Lemma read_array_list_ok : forall (l : list item) nblocks items Fi,
    length l = nblocks * items_per_val ->
    (Fi ✶ arrayN (@ptsto _ addr_eq_dec _) 0 l)%pred (list2nmem items) ->
    firstn (nblocks * items_per_val) items = l.
  Proof.
    intros.
    eapply arrayN_list2nmem in H0.
    rewrite <- H; simpl in *; auto.
    exact item0.
  Qed.

  Theorem read_array_ok : forall lxp xp nblocks ms,
    {< F Fm Fi m0 sm m items l,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[ length l = (nblocks * items_per_val)%nat ]] *
          [[[ m ::: Fm * rep xp items ]]] *
          [[[ items ::: Fi * arrayN (@ptsto _ addr_eq_dec _) 0 l ]]]
    POST:hm' RET:^(ms', r)
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm' *
          [[ r = l ]]
    CRASH:hm' exists ms',
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm'
    >} read_array lxp xp nblocks ms.
  Proof.
    unfold read_array.
    hoare.
    eapply read_array_length_ok; eauto.
    subst; eapply read_array_list_ok; eauto.
  Qed.

  Theorem ifind_array_ok : forall lxp xp cond ms,
    {< F Fm m0 sm m items,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[[ m ::: Fm * rep xp items ]]]
    POST:hm' RET:^(ms', r)
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm' *
        ( [[ r = None ]] \/ exists st,
          [[ r = Some st /\ cond (snd st) (fst st) = true ]] *
          [[[ items ::: arrayN_ex (@ptsto _ addr_eq_dec _) items (fst st) * (fst st) |-> (snd st) ]]] )
    CRASH:hm' exists ms',
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm'
    >} ifind_array lxp xp cond ms.
  Proof.
    unfold ifind_array; intros.
    hoare.
    or_r; cancel.
    apply list2nmem_ptsto_cancel; auto.
  Qed.

  Fact eq_rect_eq : forall (a : nat) (f : nat -> Type) v1 v2 c H,
    eq_rect a f v1 c H = eq_rect a f v2 c H -> v1 = v2.
  Proof.
    intros a f v1 v2 c H.
    subst; auto.
  Qed.

  Ltac eq_rect_eq := match goal with [H : eq_rect _ _ _ _ _ = eq_rect _ _ _ _ _ |- _] =>
      apply eq_rect_eq in H;
      eapply f_equal in H;
      rewrite Rec.of_to_id in H;
      rewrite Rec.of_to_id in H
    end.

  Lemma ipack_inj : forall ra l1 l2,
    items_valid ra l1 ->
    items_valid ra l2 ->
    ipack l1 =ipack l2 -> l1 = l2.
  Proof.
    unfold items_valid.
    intros ra.
    generalize (RALen ra) as r; intro r; destruct r.
    intros; subst; simpl in *; intuition.
    rewrite length_nil with (l := l2); auto.
    rewrite length_nil with (l := l1); auto.
    induction r; intros; intuition.
    simpl in *; rewrite plus_0_r in *.
    rewrite ipack_one in *; auto.
    rewrite ipack_one in *; auto.
    match goal with [H : _::_ = _::_ |- _] => inversion H; clear H end.
    unfold block2val, word2val, eq_rec_r, eq_rec in *.
    simpl in *.
    eq_rect_eq; auto; unfold Rec.well_formed; simpl; intuition.
    repeat match goal with
      [ lx : itemlist,
        Hl : length ?lx = _,
        H : context [ipack ?lx] |- _] =>
        erewrite <- firstn_skipn with (l := lx) (n := items_per_val) in H;
        erewrite ipack_app with (na := 1) in H;
        [> erewrite <- firstn_skipn with (l := lx) | ];
        [> erewrite ipack_one with (l := firstn _ _) in H | ]
    end; simpl in *; try rewrite plus_0_r in *.
    match goal with [H: _::_ = _::_ |- _ ] => inversion H end.
    unfold block2val, word2val, eq_rec_r, eq_rec in *.
    simpl in *.
    eq_rect_eq.
    f_equal; eauto.
    apply IHr; intuition.
    all : repeat (
          auto || lia || split  ||
          unfold item in *      ||
          rewrite skipn_length  ||
          apply forall_skipn    ||
          apply forall_firstn   ||
          apply firstn_length_l ).
  Qed.

  Hint Extern 1 ({{_}} Bind (get_array _ _ _ _) _) => apply get_array_ok : prog.
  Hint Extern 1 ({{_}} Bind (put_array _ _ _ _ _) _) => apply put_array_ok : prog.
  Hint Extern 1 ({{_}} Bind (read_array _ _ _ _) _) => apply read_array_ok : prog.
  Hint Extern 1 ({{_}} Bind (ifind_array _ _ _ _) _) => apply ifind_array_ok : prog.

  (* If two arrays are in the same spot, their contents have to be equal *)
  Hint Extern 0 (okToUnify (rep ?xp _) (rep ?xp _)) => constructor : okToUnify.

  Theorem rep_inj : forall F1 F2 l1 l2 ra m,
    (F1 * rep ra l1)%pred m -> (F2 * rep ra l2)%pred m -> l1 = l2.
  Proof.
    intros.
    unfold rep in *.
    repeat match goal with
      [ H : (_ * (exis _))%pred _ |- _ ] => destruct_lift H
      end.
    match goal with
      [ H : context[synced_list _] |- _] =>  eapply arrayN_unify', synced_list_inj in H
    end.
    eapply ipack_inj; eauto.
    repeat rewrite synced_list_length.
    repeat rewrite ipack_length.
    f_equal.
    unfold items_valid in *; intuition.
    unfold item in *.
    omega.
    eassumption.
  Qed.

  Lemma items_wellformed : forall F xp l m,
    (F * rep xp l)%pred m -> Forall Rec.well_formed l.
  Proof.
    unfold rep, items_valid; intuition.
    destruct_lift H; auto.
  Qed.

  Lemma items_wellformed_pimpl : forall xp l,
    rep xp l =p=> [[ Forall Rec.well_formed l ]] * rep xp l.
  Proof.
    unfold rep, items_valid; cancel.
  Qed.

  Lemma item_wellformed : forall F xp m l i,
    (F * rep xp l)%pred m -> Rec.well_formed (selN l i item0).
  Proof.
    intros.
    destruct (lt_dec i (length l)).
    apply Forall_selN; auto.
    eapply items_wellformed; eauto.
    rewrite selN_oob by omega.
    apply item0_wellformed.
  Qed.

  Lemma items_length_ok : forall F xp l m,
    (F * rep xp l)%pred m ->
    length l = (RALen xp) * items_per_val.
  Proof.
    unfold rep, items_valid; intuition.
    destruct_lift H; auto.
  Qed.

  Lemma items_length_ok_pimpl : forall xp l,
    rep xp l =p=> [[ length l = ((RALen xp) * items_per_val)%nat ]] * rep xp l.
  Proof.
    unfold rep, items_valid; cancel.
  Qed.

  Theorem xform_rep : forall xp l,
    crash_xform (rep xp l) <=p=> rep xp l.
  Proof.
    unfold rep; intros; split.
    xform_norm.
    rewrite crash_xform_arrayN_synced; cancel.
    cancel.
    xform_normr; cancel.
    rewrite <- crash_xform_arrayN_r; eauto.
    apply possible_crash_list_synced_list.
  Qed.

End LogRecArray.

Module LogRecArrayCache (RA : RASig).

  Module LRA := LogRecArray RA.
  Module Defs := LRA.Defs.
  Import RA LRA.Defs.

  Module Cache := FMapAVL.Make(Nat_as_OT).
  Module CacheDefs := MapDefs Nat_as_OT Cache.
  Definition Cache_type := Cache.t item.
  Module M := MapMem Nat_as_OT Cache.
  Definition cache0 : Cache_type := Cache.empty item.

  Definition cache_ptsto i (v : item) : @pred _ addr_eq_dec _ :=
    ( i |-> v \/ emp )%pred.

  Definition cache_rep (items : itemlist) (c : Cache_type) :=
     arrayN cache_ptsto 0 items (M.mm _ c).

  Definition rep xp (items : itemlist) c :=
    ( LRA.rep xp items * [[ cache_rep items c ]] )%pred.

  Definition get lxp xp ix cache ms :=
    match Cache.find ix cache with
    | Some v =>
      Ret ^(cache, ms, v)
    | None =>
      let^ (ms, v) <- LRA.get lxp xp ix ms;
      AlertModified;;
      Ret ^(Cache.add ix v cache, ms, v)
    end.

  Definition put lxp xp ix item cache ms :=
    ms <- LRA.put lxp xp ix item ms;
    Ret ^(Cache.add ix item cache, ms).

  Definition read := LRA.read.
  Definition write := LRA.write.
  Definition init := LRA.init.
  Definition ifind := LRA.ifind.

  Definition get_array lxp xp ix cache ms :=
    r <- get lxp xp ix cache ms;
    Ret r.

  Definition put_array lxp xp ix item cache ms :=
    r <- put lxp xp ix item cache ms;
    Ret r.

  Definition read_array lxp xp nblocks ms :=
    r <- read lxp xp nblocks ms;
    Ret r.

  Definition ifind_array lxp xp cond ms :=
    r <- ifind lxp xp cond ms;
    Ret r.

  Definition read_ok := LRA.read_ok.

  Definition write_ok := LRA.write_ok.

  Definition init_ok := LRA.init_ok.

  Definition ifind_ok := LRA.ifind_ok.

  Hint Extern 1 ({{_}} Bind (read _ _ _ _) _) => apply read_ok : prog.
  Hint Extern 1 ({{_}} Bind (write _ _ _ _) _) => apply write_ok : prog.
  Hint Extern 1 ({{_}} Bind (init _ _ _) _) => apply init_ok : prog.

  Lemma item_wellformed : forall F xp m i l cache,
    (F ✶ rep xp l cache)%pred m ->
    Rec.well_formed (selN l i item0).
  Proof.
    unfold rep.
    intros.
    destruct_lifts.
    eauto using LRA.item_wellformed.
  Qed.

  Lemma items_length_ok_pimpl : forall xp l cache,
    rep xp l cache =p=>
    [[ length l = (RALen xp * items_per_val)%nat ]] ✶ rep xp l cache.
  Proof.
    unfold rep.
    intros xp l c m H.
    rewrite LRA.items_length_ok_pimpl in H.
    pred_apply.
    cancel.
  Qed.

  Lemma xform_rep : forall xp l c,
    crash_xform (rep xp l c) <=p=> rep xp l c.
  Proof.
    unfold rep.
    intros.
    xform_norm.
    rewrite LRA.xform_rep.
    split; cancel.
  Qed.

  Lemma cache_rep_empty : forall l,
    cache_rep l (Cache.empty _).
  Proof.
    unfold cache_rep, M.mm.
    intro l. generalize 0. revert l.
    induction l; intros.
    intro; auto.
    simpl. unfold_sep_star.
    repeat exists (M.mm _ (Cache.empty _)).
    intuition.
    cbv. intro. repeat deex. congruence.
    right.
    intro; auto.
  Qed.

  Lemma rep_clear_cache: forall xp items cache,
    rep xp items cache =p=> rep xp items cache0.
  Proof.
    unfold rep. cancel.
    apply cache_rep_empty.
  Qed.

  Lemma arrayN_cache_ptsto_oob: forall l i m x,
    arrayN (cache_ptsto) x l m -> i >= length l + x \/ i < x -> m i = None.
  Proof.
    induction l; cbn; intros; auto.
    unfold sep_star in H.
    rewrite sep_star_is in H.
    unfold sep_star_impl in H.
    repeat deex.
    all: eapply mem_union_sel_none.
    all : solve [
      cbv in H2; intuition auto; apply H3; omega |
      eapply IHl; eauto; omega].
  Qed.

  Lemma cache_rep_some : forall items i cache v d,
    Cache.find i cache = Some v ->
    i < length items ->
    cache_rep items cache ->
    v = selN items i d.
  Proof.
    unfold cache_rep.
    intros items i cache v d.
    change (Cache.find i cache) with (M.mm _ cache i).
    generalize (M.mm item cache).
    clear cache.
    intros.
    eapply isolateN_fwd in H1; eauto.
    autorewrite with core in *.
    unfold cache_ptsto in H1 at 2.
    eapply pimpl_trans in H1.
    2 : rewrite sep_star_assoc, sep_star_comm, sep_star_assoc; reflexivity.
    2 : reflexivity.
    unfold sep_star in H1.
    rewrite sep_star_is in H1.
    unfold sep_star_impl, or, ptsto, emp in H1.
    intuition repeat deex.
    erewrite mem_union_addr in H by eauto.
    inversion H. eauto.
    rewrite mem_union_sel_none in H; try congruence.
    apply mem_union_sel_none.
    eapply arrayN_cache_ptsto_oob; eauto. omega.
    eapply arrayN_cache_ptsto_oob; eauto.
    rewrite firstn_length_l; omega.
  Qed.

  Lemma cache_rep_add : forall items i cache d,
    i < length items ->
    cache_rep items cache ->
    cache_rep items (Cache.add i (selN items i d) cache).
  Proof.
    unfold cache_rep in *.
    intros.
    rewrite M.mm_add_upd.
    destruct (M.mm _ cache i) eqn:?.
    eapply cache_rep_some in H0 as ?; eauto.
    rewrite Mem.upd_nop; eauto.
    rewrite Heqo. f_equal. eauto.
    generalize dependent (M.mm _ cache). clear cache.
    intros.
    eapply arrayN_mem_upd_none; eauto.
    edestruct arrayN_except as [H' _]; eauto; apply H' in H0; clear H'.
    unfold sep_star in *.
    rewrite sep_star_is in *.
    unfold sep_star_impl in *.
    repeat deex.
    apply mem_union_none_sel in Heqo.
    cbv [cache_ptsto or ptsto] in *.
    intuition try congruence.
    apply emp_empty_mem_only in H5. subst.
    rewrite mem_union_empty_mem'. auto.
    cbv [cache_ptsto ptsto or].
    left.
    intuition (destruct addr_eq_dec); eauto; congruence.
  Unshelve.
    exact item0.
  Qed.

  Lemma cache_ptsto_upd : forall i v0 v m,
    cache_ptsto i v0 m -> cache_ptsto i v (Mem.upd m i v).
  Proof.
    cbv [cache_ptsto or].
    intros.
    left.
    intuition auto.
    pose proof (@ptsto_upd _ addr_eq_dec _ i v v0 emp).
    eapply pimpl_trans; try apply H; try pred_apply; cancel.
    pose proof (@ptsto_upd_disjoint _ addr_eq_dec _ emp i v).
    eapply pimpl_trans; try apply H; try pred_apply; try cancel.
    cbv in *; auto.
  Qed.

  Lemma cache_rep_updN : forall items cache i v,
    i < length items ->
    cache_rep items cache ->
    cache_rep (updN items i v) (Cache.add i v cache).
  Proof.
    unfold cache_rep in *.
    intros.
    rewrite M.mm_add_upd.
    generalize dependent (M.mm _ cache). clear cache.
    intros.
    edestruct arrayN_isolate as [H' _]; eauto; apply H' in H0; clear H'.
    edestruct arrayN_isolate as [_ H']; [| apply H'; clear H'].
    rewrite length_updN; eauto.
    simpl in *.
    rewrite selN_updN_eq by auto.
    rewrite firstn_updN_oob by auto.
    rewrite skipn_updN by auto.
    revert H0.
    unfold_sep_star.
    intuition repeat deex.
    assert (mem_disjoint m0 (Mem.upd m3 i v)).
    cbv [cache_ptsto or ptsto] in H6.
    cbv [mem_disjoint Mem.upd] in *.
    intuition repeat deex.
    destruct addr_eq_dec; subst; eauto 10.
    destruct addr_eq_dec; subst; eauto 10.
    erewrite arrayN_cache_ptsto_oob in H6; eauto; try congruence.
    rewrite firstn_length_l; omega.
    apply mem_disjoint_union in H0 as ?.
    assert (mem_disjoint (Mem.upd m3 i v) m2).
    cbv [cache_ptsto or ptsto] in H6.
    cbv [mem_disjoint Mem.upd] in *.
    intuition repeat deex.
    destruct addr_eq_dec; subst; eauto 10.
    destruct addr_eq_dec; subst; eauto 10.
    erewrite arrayN_cache_ptsto_oob in H9; eauto; try congruence; omega.
    repeat eexists; try eapply cache_ptsto_upd; eauto.
    rewrite mem_union_comm with (m1 := m0) by auto.
    repeat rewrite <- mem_union_upd.
    f_equal.
    apply mem_union_comm, mem_disjoint_comm; auto.
    apply mem_disjoint_mem_union_split_l; auto.
    apply mem_disjoint_comm.
    eapply mem_disjoint_union_2.
    apply mem_disjoint_comm.
    eauto.
  Unshelve. all : eauto.
  Qed.

  Theorem get_array_ok : forall lxp xp ix cache ms,
    {< F Fm m0 sm m items,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[ ix < length items ]] *
          [[[ m ::: Fm * rep xp items cache ]]]
    POST:hm' RET:^(cache', ms', r)
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm' *
          [[[ m ::: Fm * rep xp items cache' ]]] *
          [[ r = selN items ix item0 ]]
    CRASH:hm' exists ms',
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms' sm hm'
    >} get_array lxp xp ix cache ms.
  Proof.
    unfold get_array, get, rep.
    hoare.
    all : eauto using cache_rep_some, cache_rep_add.
  Qed.

  Theorem put_array_ok : forall lxp xp ix e cache ms,
    {< F Fm Fi m0 sm m items e0,
    PRE:hm
          LOG.rep lxp F (LOG.ActiveTxn m0 m) ms sm hm *
          [[ Rec.well_formed e ]] *
          [[[ m ::: Fm * rep xp items cache ]]] *
          [[[ items ::: Fi * (ix |-> e0) ]]]
    POST:hm' RET:^(cache', ms') exists m' items',
          LOG.rep lxp F (LOG.ActiveTxn m0 m') ms' sm hm' *
          [[ items' = updN items ix e ]] *
          [[[ m' ::: Fm * rep xp items' cache' ]]] *
          [[[ items' ::: Fi * (ix |-> e) ]]]
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} put_array lxp xp ix e cache ms.
  Proof.
    unfold put_array, put, rep.
    hoare.
    eapply list2nmem_ptsto_bound; eauto.
    eapply cache_rep_updN; eauto.
    eapply list2nmem_ptsto_bound; eauto.
    eapply list2nmem_updN; eauto.
  Qed.

  Hint Extern 1 ({{_}} Bind (get_array _ _ _ _ _) _) => apply get_array_ok : prog.
  Hint Extern 1 ({{_}} Bind (put_array _ _ _ _ _ _) _) => apply put_array_ok : prog.

  Hint Extern 0 (okToUnify (rep ?xp _ _) (rep ?xp _ _)) => constructor : okToUnify.

End LogRecArrayCache.


(* SPDX-License-Identifier: GPL-2.0 *)
Require Import Coqlib.
Require Import Maps.
Require Import Integers.
Require Import Values.
Require Import GenSem.
Require Import Maps.
Require Import Integers.
Require Import Values.
Require Import RealParams.
Require Import GenSem.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import PrimSemantics.
Require Import CompatClightSem.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.

Require Import MmioPTWalk.Spec.
Require Import RData.
Require Import Constants.
Require Import AbstractMachine.Spec.
Require Import MmioPTWalk.Layer.
Require Import HypsecCommLib.

Local Open Scope Z_scope.

Section MmioSPTWalkSpec.

  Definition clear_smmu_pt_spec (cbndx: Z) (index: Z) (adt: RData) : option RData :=
    rely is_smmu index; rely is_smmu_cfg cbndx;
    if halt adt then Some adt else
    let id := SPT_ID in
    match ZMap.get id (lock adt) with
    | LockOwn true =>
      let ttbr := SMMU_TTBR index cbndx in
      let spt := spts (shared adt) in
      let pt0 := ZMap.init (0, 0) in
      let pgd_t0 := ZMap.init false in
      let pmd_t0 := ZMap.init (ZMap.init false) in
      let spt' := spt {spt_pt: (spt_pt spt) # ttbr == pt0} {spt_pgd_t: (spt_pgd_t spt) # ttbr == pgd_t0} {spt_pmd_t: (spt_pmd_t spt) # ttbr == pmd_t0} in
      Some adt {tstate: 1} {shared: (shared adt) {spts: spt'}}
    | _  => None
    end.

  Definition walk_smmu_pt_spec (cbndx: Z) (index: Z) (addr: Z64) (adt: RData) : option Z64 :=
    match addr with
    | VZ64 addr =>
      rely is_smmu index; rely is_smmu_cfg cbndx; rely is_smmu_addr addr;
      if halt adt then Some (VZ64 0) else
      let id := SPT_ID in
      match ZMap.get id (lock adt) with
      | LockOwn true =>
        let ttbr := SMMU_TTBR index cbndx in
        let pt := ttbr @ (spt_pt (spts (shared adt))) in
        let gfn := addr / PAGE_SIZE in
        match ZMap.get gfn pt with
        | (pfn, pte) => Some (VZ64 pte)
        end
      | _  => None
      end
    end.

  Definition local_spt_map (cbndx: Z) (index: Z) (addr: Z) (pte: Z) (spt: SPT) :=
    let gfn := addr / PAGE_SIZE in
    let pfn := (phys_page pte) / PAGE_SIZE in
    let ttbr := SMMU_TTBR index cbndx in
    let pt := ttbr @ (spt_pt spt) in
    match gfn @ pt with
    | (pfn0, pte0) =>
      let pgd_next' := (if (stage2_pgd_index addr) @ (ttbr @ (spt_pgd_t spt)) then (spt_pgd_next spt) else (spt_pgd_next spt) + PAGE_SIZE) in
      let pmd_next' := (if (pmd_index addr) @ ((stage2_pgd_index addr) @ (ttbr @ (spt_pmd_t spt)))
                        then (spt_pmd_next spt) else (spt_pmd_next spt) + PAGE_SIZE) in
      if (pgd_next' <=? SMMU_PMD_START) && (pmd_next'  <=? SMMU_POOL_END) then
        let spt' := spt {spt_pt: (spt_pt spt) # ttbr == (pt # gfn == (pfn, pte))}
                        {spt_pgd_t: (spt_pgd_t spt) # ttbr == ((ttbr @ (spt_pgd_t spt)) # (stage2_pgd_index addr) == true)}
                        {spt_pmd_t: (spt_pmd_t spt) # ttbr ==
                                    ((ttbr @ (spt_pmd_t spt)) # (stage2_pgd_index addr) ==
                                    (((stage2_pgd_index addr) @ (ttbr @ (spt_pmd_t spt))) # (pmd_index addr) == true))}
                        {spt_pgd_next: pgd_next'} {spt_pmd_next: pmd_next'}
        in
        Some (false, spt')
      else Some (true, spt)
    end.

  Definition set_smmu_pt_spec (cbndx: Z) (index: Z) (addr: Z64) (pte: Z64) (adt: RData) : option RData :=
    match addr, pte with
    | VZ64 addr, VZ64 pte =>
      rely is_smmu index; rely is_smmu_cfg cbndx;
      rely is_smmu_addr addr; rely is_int64 pte;
      if halt adt then Some adt else
      rely (tstate adt =? 0);
      let id := SPT_ID in
      match ZMap.get id (lock adt) with
      | LockOwn true =>
        match local_spt_map cbndx index addr pte (spts (shared adt)) with
        | Some (halt', spt') =>
          Some adt {tstate: if halt' then 0 else 1} {halt: halt'} {shared: (shared adt) {spts: spt'}}
        | _ => None
        end
      | _  => None
      end
    end.

  Definition dev_load_ref_spec (gfn: Z64) (reg: Z) (cbndx: Z) (index: Z) (adt: RData) : option RData :=
    match gfn with
    | VZ64 gfn =>
      dev_load_raw_spec (VZ64 gfn) reg cbndx index adt
    end.

  Definition dev_store_ref_spec (gfn: Z64) (reg: Z) (cbndx: Z) (index: Z) (adt: RData) : option RData :=
    match gfn with
    | VZ64 gfn =>
      dev_store_raw_spec (VZ64 gfn) reg cbndx index adt
    end.

End MmioSPTWalkSpec.

Section MmioSPTWalkSpecLow.

  Context `{real_params: RealParams}.

  Notation LDATA := RData.

  Notation LDATAOps := (cdata (cdata_ops := MmioPTWalk_ops) LDATA).

  Definition clear_smmu_pt_spec0 (cbndx: Z) (index: Z) (adt: RData) : option RData :=
    smmu_pt_clear_spec cbndx index adt.

  Definition walk_smmu_pt_spec0 (cbndx: Z) (index: Z) (addr: Z64) (adt: RData) : option Z64 :=
    match addr with
    | VZ64 addr =>
      when' ttbr == get_smmu_cfg_hw_ttbr_spec cbndx index adt;
      rely is_int64 ttbr;
      when' pgd, adt1 == walk_smmu_pgd_spec (VZ64 ttbr) (VZ64 addr) 0 adt;
      rely is_int64 pgd;
      when' pmd, adt2 == walk_smmu_pmd_spec (VZ64 pgd) (VZ64 addr) 0 adt;
      rely is_int64 pmd;
      when' pte == walk_smmu_pte_spec (VZ64 pmd) (VZ64 addr) adt;
      rely is_int64 pte;
      check64_spec (VZ64 pte) adt
    end.

  Definition set_smmu_pt_spec0 (cbndx: Z) (index: Z) (addr: Z64) (pte: Z64) (adt: RData) : option RData :=
    match addr, pte with
    | VZ64 addr, VZ64 pte =>
      when' ttbr == get_smmu_cfg_hw_ttbr_spec cbndx index adt;
      rely is_int64 ttbr;
      when' pgd, adt1 == walk_smmu_pgd_spec (VZ64 ttbr) (VZ64 addr) 1 adt;
      rely is_int64 pgd;
      when' pmd, adt2 == walk_smmu_pmd_spec (VZ64 pgd) (VZ64 addr) 1 adt1;
      rely is_int64 pmd;
      set_smmu_pte_spec (VZ64 pmd) (VZ64 addr) (VZ64 pte) adt2
    end.

  Definition dev_load_ref_spec0 (gfn: Z64) (reg: Z) (cbndx: Z) (index: Z) (adt: RData) : option RData :=
    match gfn with
    | VZ64 gfn =>
      dev_load_raw_spec (VZ64 gfn) reg cbndx index adt
    end.

  Definition dev_store_ref_spec0 (gfn: Z64) (reg: Z) (cbndx: Z) (index: Z) (adt: RData) : option RData :=
    match gfn with
    | VZ64 gfn =>
      dev_store_raw_spec (VZ64 gfn) reg cbndx index adt
    end.

  Inductive clear_smmu_pt_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | clear_smmu_pt_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' cbndx index
      (Hinv: high_level_invariant labd)
      (Hspec: clear_smmu_pt_spec0 (Int.unsigned cbndx) (Int.unsigned index) labd = Some labd'):
      clear_smmu_pt_spec_low_step s WB ((Vint cbndx)::(Vint index)::nil) (m'0, labd) Vundef (m'0, labd').

  Inductive walk_smmu_pt_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | walk_smmu_pt_spec_low_intro s (WB: _ -> Prop) m'0 labd cbndx index addr res
      (Hinv: high_level_invariant labd)
      (Hspec: walk_smmu_pt_spec0 (Int.unsigned cbndx) (Int.unsigned index) (VZ64 (Int64.unsigned addr)) labd = Some (VZ64 (Int64.unsigned res))):
      walk_smmu_pt_spec_low_step s WB ((Vint cbndx)::(Vint index)::(Vlong addr)::nil) (m'0, labd) (Vlong res) (m'0, labd).

  Inductive set_smmu_pt_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | set_smmu_pt_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' cbndx num addr pte
      (Hinv: high_level_invariant labd)
      (Hspec: set_smmu_pt_spec0 (Int.unsigned cbndx) (Int.unsigned num) (VZ64 (Int64.unsigned addr)) (VZ64 (Int64.unsigned pte)) labd = Some labd'):
      set_smmu_pt_spec_low_step s WB ((Vint cbndx)::(Vint num)::(Vlong addr)::(Vlong pte)::nil) (m'0, labd) Vundef (m'0, labd').

  Inductive dev_load_ref_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | dev_load_ref_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' gfn reg cbndx index
      (Hinv: high_level_invariant labd)
      (Hspec: dev_load_ref_spec0 (VZ64 (Int64.unsigned gfn)) (Int.unsigned reg) (Int.unsigned cbndx) (Int.unsigned index) labd = Some labd'):
      dev_load_ref_spec_low_step s WB ((Vlong gfn)::(Vint reg)::(Vint cbndx)::(Vint index)::nil) (m'0, labd) Vundef (m'0, labd').

  Inductive dev_store_ref_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | dev_store_ref_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' gfn reg cbndx index
      (Hinv: high_level_invariant labd)
      (Hspec: dev_store_ref_spec0 (VZ64 (Int64.unsigned gfn)) (Int.unsigned reg) (Int.unsigned cbndx) (Int.unsigned index) labd = Some labd'):
      dev_store_ref_spec_low_step s WB ((Vlong gfn)::(Vint reg)::(Vint cbndx)::(Vint index)::nil) (m'0, labd) Vundef (m'0, labd').

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModelX}.
    Context `{Hmwd: UseMemWithData mem}.

    Definition clear_smmu_pt_spec_low: compatsem LDATAOps :=
      csem clear_smmu_pt_spec_low_step (type_of_list_type (Tint32::Tint32::nil)) Tvoid.

    Definition walk_smmu_pt_spec_low: compatsem LDATAOps :=
      csem walk_smmu_pt_spec_low_step (type_of_list_type (Tint32::Tint32::Tint64::nil)) Tint64.

    Definition set_smmu_pt_spec_low: compatsem LDATAOps :=
      csem set_smmu_pt_spec_low_step (type_of_list_type (Tint32::Tint32::Tint64::Tint64::nil)) Tvoid.

    Definition dev_load_ref_spec_low: compatsem LDATAOps :=
      csem dev_load_ref_spec_low_step (type_of_list_type (Tint64::Tint32::Tint32::Tint32::nil)) Tvoid.

    Definition dev_store_ref_spec_low: compatsem LDATAOps :=
      csem dev_store_ref_spec_low_step (type_of_list_type (Tint64::Tint32::Tint32::Tint32::nil)) Tvoid.

  End WITHMEM.

End MmioSPTWalkSpecLow.


Require Import RelationClasses.
Require Import Bool.
Require Import List.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.

Require Import FulfillStep.
Require Import SimMemory.
Require Import SimPromises.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Inductive sim_local (lc_src lc_tgt:Local.t): Prop :=
| sim_local_intro
    (TVIEW: TView.le lc_src.(Local.tview) lc_tgt.(Local.tview))
    (PROMISES: SimPromises.sem SimPromises.bot SimPromises.bot lc_src.(Local.promises) lc_tgt.(Local.promises))
.

Program Instance sim_local_PreOrder: PreOrder sim_local.
Next Obligation.
  econs; try refl. apply SimPromises.sem_bot.
Qed.
Next Obligation.
  ii. inv H. inv H0. econs; try etrans; eauto.
  apply SimPromises.sem_bot_inv in PROMISES; auto.
  apply SimPromises.sem_bot_inv in PROMISES0; auto.
  rewrite PROMISES, PROMISES0. apply SimPromises.sem_bot.
Qed.

Lemma sim_local_nonsynch_loc
      loc lc_src lc_tgt
      (SIM: sim_local lc_src lc_tgt)
      (NONSYNCH: Memory.nonsynch_loc loc lc_tgt.(Local.promises)):
  Memory.nonsynch_loc loc lc_src.(Local.promises).
Proof.
  inv SIM. eapply SimPromises.sem_bot_inv in PROMISES; auto. rewrite PROMISES. auto.
Qed.

Lemma sim_local_nonsynch
      lc_src lc_tgt
      (SIM: sim_local lc_src lc_tgt)
      (NONSYNCH: Memory.nonsynch lc_tgt.(Local.promises)):
  Memory.nonsynch lc_src.(Local.promises).
Proof.
  ii. eapply sim_local_nonsynch_loc; eauto.
Qed.

Lemma sim_local_memory_bot
      lc_src lc_tgt
      (SIM: sim_local lc_src lc_tgt)
      (BOT: lc_tgt.(Local.promises) = Memory.bot):
  lc_src.(Local.promises) = Memory.bot.
Proof.
  inv SIM. eapply SimPromises.sem_bot_inv in PROMISES; auto. rewrite PROMISES. auto.
Qed.

Lemma sim_local_promise
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt mem2_tgt
      loc from to val released kind
      (STEP_TGT: Local.promise_step lc1_tgt mem1_tgt loc from to val released lc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src mem2_src,
    <<STEP_SRC: Local.promise_step lc1_src mem1_src loc from to val released lc2_src mem2_src kind>> /\
    <<LOCAL2: sim_local lc2_src lc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit SimPromises.promise_bot; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  i. des.
  exploit sim_memory_closed_opt_view; eauto. i.
  exploit Memory.promise_future; try apply PROMISE_SRC; eauto.
  { apply WF1_SRC. }
  { apply WF1_SRC. }
  i. des.
  esplits; eauto.
  - econs; eauto.
  - econs; eauto.
Qed.

Lemma sim_local_read
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt
      loc ts val released_tgt ord_src ord_tgt
      (STEP_TGT: Local.read_step lc1_tgt mem1_tgt loc ts val released_tgt ord_tgt lc2_tgt)
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt):
  exists released_src lc2_src,
    <<REL: View.opt_le released_src released_tgt>> /\
    <<STEP_SRC: Local.read_step lc1_src mem1_src loc ts val released_src ord_src lc2_src>> /\
    <<LOCAL2: sim_local lc2_src lc2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit sim_memory_get; try apply MEM1; eauto. i. des.
  esplits; eauto.
  - econs; eauto. eapply TViewFacts.readable_mon; eauto. apply TVIEW.
  - econs; eauto. s. apply TViewFacts.read_tview_mon; auto.
    + apply WF1_TGT.
    + eapply MEM1_TGT. eauto.
Qed.

Lemma sim_local_fulfill
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      loc from to val releasedm_src releasedm_tgt released ord_src ord_tgt
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF: View.opt_wf releasedm_src)
      (RELM_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (WF_RELM_TGT: View.opt_wf releasedm_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (STEP_TGT: fulfill_step lc1_tgt sc1_tgt loc from to val releasedm_tgt released ord_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: fulfill_step lc1_src sc1_src loc from to val releasedm_src released ord_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_local lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  inv STEP_TGT.
  assert (RELT_LE:
   View.opt_le
     (TView.write_released lc1_src.(Local.tview) sc1_src loc to releasedm_src ord_src)
     (TView.write_released lc1_tgt.(Local.tview) sc2_tgt loc to releasedm_tgt ord_tgt)).
  { apply TViewFacts.write_released_mon; ss.
    - apply LOCAL1.
    - apply WF1_TGT.
  }
  assert (RELT_WF:
   View.opt_wf (TView.write_released lc1_src.(Local.tview) sc1_src loc to releasedm_src ord_src)).
  { unfold TView.write_released. condtac; econs.
    repeat (try condtac; viewtac; try apply WF1_SRC).
  }
  exploit SimPromises.remove_bot; try exact REMOVE;
    try exact MEM1; try apply LOCAL1; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  { apply WF1_TGT. }
  i. des. esplits.
  - econs; eauto.
    + etrans; eauto.
    + eapply TViewFacts.writable_mon; eauto. apply LOCAL1.
  - econs; eauto. s. apply TViewFacts.write_tview_mon; auto.
    + apply LOCAL1.
    + apply WF1_TGT.
  - ss.
Qed.

Lemma sim_local_write
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt ord_src ord_tgt kind
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_SRC_WF: View.opt_wf releasedm_src)
      (RELM_SRC_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT_WF: View.opt_wf releasedm_tgt)
      (RELM_TGT_CLOSED: Memory.closed_opt_view releasedm_tgt mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (STEP_TGT: Local.write_step lc1_tgt sc1_tgt mem1_tgt loc from to val releasedm_tgt released_tgt ord_tgt lc2_tgt sc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_step lc1_src sc1_src mem1_src loc from to val releasedm_src released_src ord_src lc2_src sc2_src mem2_src kind>> /\
    <<REL2: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_local lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  exploit write_promise_fulfill; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_promise; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_fulfill; try apply STEP2;
    try apply LOCAL2; try apply MEM2; eauto.
  { eapply Memory.future_closed_opt_view; eauto. }
  i. des.
  exploit promise_fulfill_write; try exact STEP_SRC; try exact STEP_SRC0; eauto.
  { i. exploit ORD0; eauto.
    - etrans; eauto.
    - i. des. splits; auto. eapply sim_local_nonsynch_loc; eauto.
  }
  i. des. esplits; eauto. etrans; eauto.
Qed.

Lemma sim_local_update
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt
      lc3_tgt sc3_tgt mem3_tgt
      loc ts1 val1 released1_tgt ord1_src ord1_tgt
      from2 to2 val2 released2_tgt ord2_src ord2_tgt kind
      (STEP1_TGT: Local.read_step lc1_tgt mem1_tgt loc ts1 val1 released1_tgt ord1_tgt lc2_tgt)
      (STEP2_TGT: Local.write_step lc2_tgt sc1_tgt mem1_tgt loc from2 to2 val2 released1_tgt released2_tgt ord2_tgt lc3_tgt sc3_tgt mem3_tgt kind)
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (ORD1: Ordering.le ord1_src ord1_tgt)
      (ORD2: Ordering.le ord2_src ord2_tgt):
  exists released1_src released2_src lc2_src lc3_src sc3_src mem3_src,
    <<REL1: View.opt_le released1_src released1_tgt>> /\
    <<REL2: View.opt_le released2_src released2_tgt>> /\
    <<STEP1_SRC: Local.read_step lc1_src mem1_src loc ts1 val1 released1_src ord1_src lc2_src>> /\
    <<STEP2_SRC: Local.write_step lc2_src sc1_src mem1_src loc from2 to2 val2 released1_src released2_src ord2_src lc3_src sc3_src mem3_src kind>> /\
    <<LOCAL3: sim_local lc3_src lc3_tgt>> /\
    <<SC3: TimeMap.le sc3_src sc3_tgt>> /\
    <<MEM3: sim_memory mem3_src mem3_tgt>>.
Proof.
  exploit Local.read_step_future; eauto. i. des.
  exploit sim_local_read; eauto. i. des.
  exploit Local.read_step_future; eauto. i. des.
  hexploit sim_local_write; eauto. i. des.
  esplits; eauto.
Qed.

Lemma sim_local_fence
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      ordr_src ordw_src
      ordr_tgt ordw_tgt
      (STEP_TGT: Local.fence_step lc1_tgt sc1_tgt ordr_tgt ordw_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (ORDR: Ordering.le ordr_src ordr_tgt)
      (ORDW: Ordering.le ordw_src ordw_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: Local.fence_step lc1_src sc1_src ordr_src ordw_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_local lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  inv STEP_TGT. esplits; eauto.
  - econs; eauto. i. eapply sim_local_nonsynch; eauto.
    apply RELEASE. etrans; eauto.
  - econs; try apply LOCAL1. s.
    apply TViewFacts.write_fence_tview_mon; auto; try refl.
    apply TViewFacts.read_fence_tview_mon; auto; try refl.
    + apply LOCAL1.
    + apply WF1_TGT.
    + eapply TViewFacts.read_fence_future; apply WF1_SRC.
  - apply TViewFacts.write_fence_sc_mon; auto; try refl.
    apply TViewFacts.read_fence_tview_mon; auto; try refl.
    + apply LOCAL1.
    + apply WF1_TGT.
Qed.

Lemma sim_local_program_step
      lang
      th1_src
      th1_tgt th2_tgt e_tgt
      (STEP_TGT: @Thread.program_step lang e_tgt th1_tgt th2_tgt)
      (WF1_SRC: Local.wf th1_src.(Thread.local) th1_src.(Thread.memory))
      (WF1_TGT: Local.wf th1_tgt.(Thread.local) th1_tgt.(Thread.memory))
      (SC1_SRC: Memory.closed_timemap th1_src.(Thread.sc) th1_src.(Thread.memory))
      (SC1_TGT: Memory.closed_timemap th1_tgt.(Thread.sc) th1_tgt.(Thread.memory))
      (MEM1_SRC: Memory.closed th1_src.(Thread.memory))
      (MEM1_TGT: Memory.closed th1_tgt.(Thread.memory))
      (STATE: th1_src.(Thread.state) = th1_tgt.(Thread.state))
      (LOCAL: sim_local th1_src.(Thread.local) th1_tgt.(Thread.local))
      (SC: TimeMap.le th1_src.(Thread.sc) th1_tgt.(Thread.sc))
      (MEM: sim_memory th1_src.(Thread.memory) th1_tgt.(Thread.memory)):
  exists e_src th2_src,
    <<STEP_SRC: @Thread.program_step lang e_src th1_src th2_src>> /\
    <<EVENT: ThreadEvent.get_event e_src = ThreadEvent.get_event e_tgt>> /\
    <<STATE: th2_src.(Thread.state) = th2_tgt.(Thread.state)>> /\
    <<LOCAL: sim_local th2_src.(Thread.local) th2_tgt.(Thread.local)>> /\
    <<SC: TimeMap.le th2_src.(Thread.sc) th2_tgt.(Thread.sc)>> /\
    <<MEM: sim_memory th2_src.(Thread.memory) th2_tgt.(Thread.memory)>>.
Proof.
  destruct th1_src. ss. subst. inv STEP_TGT; ss.
  inv LOCAL0; ss.
  - esplits; (try by econs; [|econs 1]; eauto); ss.
  - exploit sim_local_read; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 2]; eauto); ss.
  - hexploit sim_local_write; eauto; try refl; try by viewtac. i. des.
    esplits; (try by econs; [|econs 3]; eauto); ss.
  - exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read; eauto; try refl. i. des.
    exploit Local.read_step_future; eauto. i. des.
    hexploit sim_local_write; eauto; try refl; try by viewtac. i. des.
    esplits; (try by econs; [|econs 4]; eauto); ss.
  - exploit sim_local_fence; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 5]; eauto); ss.
  - exploit sim_local_fence; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 6]; eauto); ss.
Qed.