Require Import Common.Definitions.
Require Import Common.Memory.
Require Import Intermediate.Machine.
Require Import Lib.Monads.

Import Intermediate.

From mathcomp Require Import ssreflect ssrfun.

Set Bullet Behavior "Strict Subproofs".

Record global_env := mkGlobalEnv {
  genv_interface: Program.interface;
  genv_procedures: NMap (NMap code);
  genv_entrypoints: EntryPoint.t;
}.

Definition executing G (pc : Pointer.t) (i : instr) : Prop :=
  exists C_procs P_code,
    getm (genv_procedures G) (Pointer.component pc) = Some C_procs /\
    getm C_procs (Pointer.block pc) = Some P_code /\
    (Pointer.offset pc >= 0) % Z /\
    nth_error P_code (Z.to_nat (Pointer.offset pc)) = Some i.

Definition prepare_global_env (p: program) : global_env :=
  let '(_, procs, entrypoints) := prepare_procedures_initial_memory p in
  {| genv_interface := prog_interface p;
     genv_procedures := procs;
     genv_entrypoints := entrypoints |}.

(* global environments are computational and pure: deterministic.
   what else do I need? some kind of per-component isolation stated
   in a way that's easy to reuse *)
Lemma domm_genv_procedures : forall p,
  domm (genv_procedures (prepare_global_env p)) = domm (prog_interface p).
Proof.
  intros p.
  unfold genv_procedures, prepare_global_env.
  rewrite Extra.domm_map. (* RB: Should be domm_mapm! *)
  rewrite domm_prepare_procedures_initial_memory_aux.
  reflexivity.
Qed.

Lemma domm_genv_entrypoints : forall p,
  domm (genv_entrypoints (prepare_global_env p)) = domm (prog_interface p).
Proof.
  intros p.
  unfold genv_procedures, prepare_global_env.
  rewrite Extra.domm_map domm_prepare_procedures_initial_memory_aux.
  reflexivity.
Qed.

Definition global_env_union (genv1 genv2 : global_env) : global_env := {|
  genv_interface   := unionm (genv_interface   genv1) (genv_interface   genv2);
  genv_procedures  := unionm (genv_procedures  genv1) (genv_procedures  genv2);
  genv_entrypoints := unionm (genv_entrypoints genv1) (genv_entrypoints genv2)
|}.

Lemma prepare_global_env_link : forall {p c},
  well_formed_program p ->
  well_formed_program c ->
  linkable (prog_interface p) (prog_interface c) ->
  linkable_mains p c ->
  prepare_global_env (program_link p c) =
  global_env_union (prepare_global_env p) (prepare_global_env c).
Proof.
  intros p c Hwfp Hwfc Hlinkable Hmains.
  unfold prepare_global_env, prepare_procedures_initial_memory.
  rewrite (prepare_procedures_initial_memory_aux_after_linking
           Hwfp Hwfc Hlinkable Hmains).
  unfold global_env_union. simpl.
  rewrite !mapm_unionm.
  reflexivity.
Qed.

(* RB: NOTE: This kind of lemma is usually the composition of two unions, one
   of which is generally extant. Compare with "after_linking" lemmas. *)
Lemma imported_procedure_recombination {p c c' Cid C P} :
  Cid \notin domm (prog_interface c) ->
  imported_procedure (genv_interface (prepare_global_env (program_link p c ))) Cid C P ->
  imported_procedure (genv_interface (prepare_global_env (program_link p c'))) Cid C P.
Proof.
  intros Hdomm Himp.
  rewrite (imported_procedure_unionm_left Hdomm) in Himp.
  destruct Himp as [CI [Hcomp Himp]]. exists CI. split; [| assumption].
  unfold Program.has_component. rewrite unionmE. now rewrite Hcomp.
Qed.

Lemma genv_procedures_program_link_left_notin :
  forall {c Cid},
    Cid \notin domm (prog_interface c) ->
  forall {p},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
    (genv_procedures (prepare_global_env (program_link p c))) Cid =
    (genv_procedures (prepare_global_env p)) Cid.
Proof.
  intros c Cid Hnotin p Hwfp Hwfc Hlinkable Hmains.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable Hmains).
  unfold global_env_union; simpl.
  rewrite unionmE.
  assert (HNone : (genv_procedures (prepare_global_env c)) Cid = None)
    by (apply /dommPn; rewrite domm_genv_procedures; done).
  setoid_rewrite HNone.
  destruct ((genv_procedures (prepare_global_env p)) Cid) eqn:Hcase;
    by setoid_rewrite Hcase.
Qed.

Lemma genv_entrypoints_program_link_left :
  forall {c C},
    C \notin domm (prog_interface c) ->
  forall {p},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
  forall {P},
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p c))) =
    EntryPoint.get C P (genv_entrypoints (prepare_global_env p)).
Proof.
  intros c C Hnotin p Hwfp Hwfc Hlinkable Hmains P.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable Hmains).
  unfold EntryPoint.get, global_env_union; simpl.
  rewrite unionmE.
  assert (HNone : (genv_entrypoints (prepare_global_env c)) C = None)
    by (apply /dommPn; rewrite domm_genv_entrypoints; done).
  rewrite HNone.
  destruct ((genv_entrypoints (prepare_global_env p)) C) eqn:Hcase;
    by rewrite Hcase.
Qed.

(* RB: NOTE: Add program well-formedness if needed. *)
Lemma genv_entrypoints_interface_some p p' C P b (* pc *) :
  (* Pointer.component pc \in domm (prog_interface p) -> *)
  (* imported_procedure (genv_interface (globalenv sem')) (Pointer.component pc) C P -> *)
  well_formed_program p ->
  well_formed_program p' ->
  prog_interface p = prog_interface p' ->
  EntryPoint.get C P (genv_entrypoints (prepare_global_env p )) = Some b ->
exists b',
  EntryPoint.get C P (genv_entrypoints (prepare_global_env p')) = Some b'.
Proof.
  move=> Hwf Hwf' Hiface.
  unfold EntryPoint.get (*, prepare_global_env *) (*, genv_entrypoints *); simpl.
  (* move=> H; exists b; rewrite -H; clear H. *)
  unfold prepare_procedures_initial_memory_aux.
  unfold elementsm, odflt, oapp.
  rewrite 2!mapmE.
  unfold omap, obind, oapp; simpl.
  rewrite 2!mkfmapfE.
  rewrite -Hiface.
  destruct (C \in domm (prog_interface p)) eqn:HC.
  - rewrite HC.
    intro HSome.
    destruct ((prog_procedures p) C) as [procs |] eqn:Hcase1;
      last discriminate.
    assert (exists procs', (prog_procedures p') C = Some procs') as [procs' Hcase1'].
    { apply /dommP.
      rewrite -(wfprog_defined_procedures Hwf') -Hiface (wfprog_defined_procedures Hwf).
      apply /dommP. now exists procs. }
    (* JT: TODO: Clean up this step *)
    assert (Hbufs: prog_buffers p C <> None).
    { intros Hn.
      have: (exists procs, prog_procedures p C = Some procs) by (now exists procs).
      move=> /dommP[H].
      move: Hn => /dommPn[H'].
      move: H H'.
      rewrite -(wfprog_defined_buffers Hwf) -(wfprog_defined_procedures Hwf) => H1 H2.
      exfalso. move: H2 => /negP. by []. }
    destruct ((prog_buffers p) C) as [bufs |] eqn:Hcase2;
      last contradiction.
    assert (exists bufs', (prog_buffers p') C = Some bufs') as [bufs' Hcase2'].
    { apply /dommP.
      rewrite -(wfprog_defined_buffers Hwf') -Hiface (wfprog_defined_buffers Hwf).
      apply /dommP. now exists bufs. }
    rewrite -> Hcase1', Hcase2'.
    (* RB: NOTE: For now, phrase in terms of domains. *)
    assert (P \in domm (reserve_component_blocks p C (ComponentMemory.prealloc bufs) procs).2) as Hdomm.
    {
      apply /dommP. eauto. (* RB: TODO: Clean up this step. *)
    }
    apply /dommP.
    (* Continue to case analyze both machines in sync. *)
    unfold reserve_component_blocks. unfold reserve_component_blocks in Hdomm.
    destruct (ComponentMemoryExtra.reserve_blocks (ComponentMemory.prealloc bufs) (length procs))
      as [Cmem bs] eqn:Hblocks.
    destruct (ComponentMemoryExtra.reserve_blocks (ComponentMemory.prealloc bufs') (length procs'))
      as [Cmem' bs'] eqn:Hblocks'.
    rewrite domm_mkfmap. rewrite domm_mkfmap in Hdomm.
    rewrite <- Hiface.
    assert (Hmain : matching_mains p p') by now apply interface_implies_matching_mains.
    destruct (prog_main p) as [|] eqn:Hcase3;
      destruct (prog_main p') as [|] eqn:Hcase4.
    + match goal with
      | |- is_true (P \in seq.unzip1 (seq.pmap ?F ?L)) => remember F as fmap eqn:Hfmap
      end.
      simpl in Hfmap.
      rewrite -domm_mkfmap. rewrite -domm_mkfmap in Hdomm.
      remember (seq.zip (seq.unzip1 procs') bs') as l' eqn:Hl'.
      remember (seq.zip (seq.unzip1 procs) bs) as l eqn:Hl.
      destruct (prog_interface p C) as [iface |] eqn:Hiface_eq.
      * assert (Hin: forall l,
                   P \in domm (mkfmap (seq.pmap fmap l)) <->
                         (P \in Component.export iface \/ (P = 0 /\ C = 0)) /\ P \in domm (mkfmap l)).
        {
          clear -Hfmap.
          intros l; subst; split.
          - intros H; induction l.
            + move: H => /dommP [v Hv]; by [].
            + simpl in H; unfold oapp in H.
              destruct a as [P' b']; destruct (P' \in Component.export iface) eqn:HP';
                rewrite HP' in H; simpl in H.
              * move: H; rewrite domm_set => /fsetU1P.
                move=> [Heq | Hdomm]; subst.
                -- split; first now left.
                   rewrite domm_set; simpl.
                   apply /fsetU1P; now left.
                -- specialize (IHl Hdomm) as [IH1 IH2].
                   split; try assumption.
                   rewrite domm_set; apply /fsetU1P; now right.
              * destruct C eqn:HeqC; destruct P' eqn:HeqP'; simpl in *;
                  try (specialize (IHl H) as [IH1 IH2]; split; first assumption;
                       rewrite domm_set in_fsetU; apply /orP; now right).
                move: H; rewrite domm_set => /fsetU1P [Heq | Hdomm]; subst.
                -- split; first now right.
                   rewrite domm_set; simpl. apply /fsetU1P; now left.
                -- specialize (IHl Hdomm) as [IH1 IH2].
                   split; first assumption.
                   rewrite domm_set in_fsetU. apply /orP; now right.
          - move=> [H1 H2].
            induction l.
            + case: H2. by [].
            + simpl; unfold oapp.
              destruct a as [P' b']; destruct (P' \in Component.export iface) eqn:HP';
                rewrite HP'; simpl.
              * simpl in *.
                move: H2. rewrite domm_set in_fsetU => /orP. move => [H2 | H2].
                move: H2 => /fset1P Heq; subst.
                rewrite domm_set; apply /fsetU1P; now left.
                rewrite domm_set; apply /fsetU1P; right.
                now apply IHl.
              * destruct C eqn:HeqC; destruct P' eqn:HeqP'; simpl in *;
                  try (apply IHl;
                       move: H2; rewrite domm_set in_fsetU => /orP [H2 | H2]; last assumption;
                                                             move: H2; rewrite in_fset1; rewrite eqtype.eqE; simpl;
                                                             intros H; assert (Heq: P = S s) by (now apply /ssrnat.eqnP); subst P;
                                                             rewrite HP' in H1; destruct H1 as [? | [? ?]]; congruence).
                -- rewrite domm_set in_fsetU; apply /orP.
                   destruct P; first now left.
                   right. apply IHl.
                   move: H2; rewrite domm_set in_fsetU => /orP [H2 | H2]; last assumption.
                   inversion H2.
                -- apply IHl.
                   destruct P. destruct H1. rewrite HP' in H. congruence.
                   destruct H. congruence.
                   move: H2; rewrite domm_set in_fsetU => /orP [H2 | H2]; last assumption.
                   inversion H2.
        }
        apply Hin in Hdomm as [Hdomm1 Hdomm2].
        apply Hin; split; try assumption. simpl in *.
        (* now we are left to prove that domm (mkfmap l') ⊆ domm (mkfmap l) *)
        subst l l'.
        rewrite domm_map_zip_unzip_same_length_is_equal;
          last (symmetry; apply (ComponentMemoryExtra.reserve_blocks_length _ _ _ _ Hblocks')).
        rewrite domm_map_zip_unzip_same_length_is_equal in Hdomm2;
          last (symmetry; apply (ComponentMemoryExtra.reserve_blocks_length _ _ _ _ Hblocks)).

        (* Now we can conclude by well-formedness of p' *)
        clear -Hiface_eq Hdomm2 Hdomm1 Hiface Hcase1 Hcase1' Hwf Hwf'.
        assert (Hiface_eq': prog_interface p' C = Some iface) by now rewrite -Hiface.
        destruct Hdomm1 as [Hdomm1 | Hdomm1].
        -- assert (His_exporting': Component.is_exporting iface P) by assumption.
           pose proof wfprog_exported_procedures_existence Hwf' Hiface_eq' His_exporting'
             as [procs'' [? [? ?]]].
           assert (procs' = procs'') by congruence; subst procs''.
           apply /dommP. exists x.
           rewrite mkfmapE. assumption.
        -- destruct Hdomm1; subst.
           pose proof (wfprog_main_existence Hwf').
           destruct H as [main_procs [H1 H2]]. apply (wfprog_main_component Hwf').
           apply /dommP; exists iface; unfold Component.main; auto.
           unfold Component.main in *; unfold Procedure.main in *.
           assert (main_procs = procs') by congruence.
           subst; auto. rewrite domm_mkfmap.
           unfold domm in *. (* ... *)
           rewrite in_fset in H2. assumption.
      * assert (H: seq.pmap fmap l = []).
        {
          clear -Hfmap.
          subst.
          induction l. by [].
          rewrite //= /oapp; now destruct a.
        }
        rewrite H in Hdomm; clear -Hdomm; exfalso.
        move: Hdomm => //=. apply /negP.
        now rewrite domm0.
    + now rewrite -> (proj1 Hmain Hcase3) in Hcase4. (* Contra. *)
    + now rewrite -> (proj2 Hmain Hcase4) in Hcase3. (* Contra. *)
    + (* Finish synchronizing both runs. Refer to first case as needed. Since
         there are no main procedures, the complications of that case are
         avoided here. *)
      match goal with
      | |- is_true (P \in seq.unzip1 (seq.pmap ?F ?L)) => remember F as fmap eqn:Hfmap
      end.

      (* First attempt *)
      rewrite -domm_mkfmap. rewrite -domm_mkfmap in Hdomm.
      remember (seq.zip (seq.unzip1 procs') bs') as l' eqn:Hl'.
      remember (seq.zip (seq.unzip1 procs) bs) as l eqn:Hl.
      destruct (prog_interface p C) as [iface |] eqn:Hiface_eq.
      * (* this assert helps simplify the expression *)
        assert (Hin : forall l,
                   P \in domm (mkfmap (seq.pmap fmap l)) <->
                         (P \in Component.export iface /\ P \in domm (mkfmap l))).
        { clear -Hfmap.
          intros l.
          subst.
          split.
          - intros H.
            induction l.
            + move: H => /dommP [v Hv]; case: Hv. by [].
            + simpl in H; unfold oapp in H.
              destruct a as [P' b']; destruct (P' \in Component.export iface) eqn:HP';
                rewrite HP' in H; simpl in H.
              * move: H; rewrite domm_set => /fsetU1P.
                move=> [Heq | Hdomm]; subst.
                -- split; first assumption.
                   rewrite domm_set.
                   simpl; apply /fsetU1P; now left.
                -- specialize (IHl Hdomm) as [IH1 IH2].
                   split; try assumption.
                   rewrite domm_set; apply /fsetU1P; now right.
              * simpl in *.
                specialize (IHl H) as [IH1 IH2].
                split; first assumption.
                rewrite domm_set. rewrite in_fsetU.
                apply /orP. now right.
          - move=> [H1 H2].
            induction l.
            + case: H2. by [].
            + simpl; unfold oapp.
              destruct a as [P' b']; destruct (P' \in Component.export iface) eqn:HP';
                rewrite HP'; simpl.
              * simpl in *.
                move: H2. rewrite domm_set in_fsetU => /orP. move => [H2 | H2].
                move: H2 => /fset1P Heq; subst.
                rewrite domm_set; apply /fsetU1P; now left.
                rewrite domm_set; apply /fsetU1P; right.
                now apply IHl.
              * simpl in *.
                apply IHl.
                move: H2. rewrite domm_set in_fsetU => /orP. move=> [H2 | H3]; last assumption.
                move: H2; rewrite in_fset1.
                rewrite eqtype.eqE. simpl.
                intros H. assert (Heq: P = P') by now apply /ssrnat.eqnP.
                rewrite Heq in H1. rewrite HP' in H1. inversion H1.
        }
        apply Hin in Hdomm as [Hdomm1 Hdomm2].
        apply Hin; split; try assumption. simpl in *.
        (* now we are left to prove that domm (mkfmap l') ⊆ domm (mkfmap l) *)
        subst l l'.
        rewrite domm_map_zip_unzip_same_length_is_equal;
          last (symmetry; apply (ComponentMemoryExtra.reserve_blocks_length _ _ _ _ Hblocks')).
        rewrite domm_map_zip_unzip_same_length_is_equal in Hdomm2;
          last (symmetry; apply (ComponentMemoryExtra.reserve_blocks_length _ _ _ _ Hblocks)).

        (* Now we can conclude by well-formedness of p' *)
        clear -Hiface_eq Hdomm2 Hdomm1 Hiface Hcase1 Hcase1' Hwf Hwf'.
        assert (Hiface_eq': prog_interface p' C = Some iface) by now rewrite -Hiface.
        assert (His_exporting': Component.is_exporting iface P) by assumption.
        pose proof wfprog_exported_procedures_existence Hwf' Hiface_eq' His_exporting'
          as [procs'' [? [? ?]]].
        assert (procs' = procs'') by congruence; subst procs''.
        apply /dommP. exists x.
        rewrite mkfmapE. assumption.
      * assert (H: seq.pmap fmap l = []).
        {
          clear -Hfmap.
          subst.
          induction l. by [].
          rewrite //= /oapp; now destruct a.
        }
        rewrite H in Hdomm; clear -Hdomm; exfalso.
        move: Hdomm => //=. apply /negP.
        now rewrite domm0.
  - now rewrite HC.
Qed.

(* RB: NOTE: The two EntryPoint lemmas can be phrased as a more general one
   operating on an explicit program link, one then being the exact symmetric of
   the other, i.e., its application after communativity of linking. There is a
   choice of encoding of component membership in both cases. *)

(* RB: TODO: Rephrase goal as simple equality? *)
(* Search _ EntryPoint.get. *)
Lemma genv_entrypoints_recombination_left :
  forall p c c',
    well_formed_program p ->
    well_formed_program c ->
    well_formed_program c' ->
    mergeable_interfaces (prog_interface p) (prog_interface c) ->
    prog_interface c = prog_interface c' ->
  forall C P b,
    C \in domm (prog_interface p) ->
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p c ))) = Some b ->
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p c'))) = Some b.
Proof.
  intros p c c' Hwfp Hwfc Hwfc' Hmergeable_ifaces Hifacec C P b Hdomm Hentry.
  pose proof proj1 Hmergeable_ifaces as Hlinkable.
  eapply (domm_partition_notin _ _ (mergeable_interfaces_sym _ _ Hmergeable_ifaces)) in Hdomm.
  rewrite genv_entrypoints_program_link_left in Hentry; try assumption;
    [| now apply linkable_implies_linkable_mains].
  rewrite Hifacec in Hlinkable, Hdomm.
  rewrite genv_entrypoints_program_link_left; try assumption.
  now apply linkable_implies_linkable_mains.
Qed.

Lemma genv_entrypoints_recombination_right :
  forall p c p' c',
    well_formed_program p ->
    well_formed_program p' ->
    well_formed_program c' ->
    mergeable_interfaces (prog_interface p) (prog_interface c) ->
    prog_interface p = prog_interface p' ->
    prog_interface c = prog_interface c' ->
  forall C P b,
    C \in domm (prog_interface c) ->
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p' c'))) = Some b ->
    EntryPoint.get C P (genv_entrypoints (prepare_global_env (program_link p  c'))) = Some b.
Proof.
  intros p c p' c' Hwfp Hwfp' Hwfc' Hmergeable_ifaces Hifacep Hifacec C P b Hdomm Hentry.
  pose proof proj1 Hmergeable_ifaces as Hlinkable.
  rewrite program_linkC in Hentry; try congruence.
  rewrite program_linkC; try congruence.
  eapply genv_entrypoints_recombination_left with (c := p'); try assumption; try congruence.
  rewrite -Hifacec -Hifacep. now apply mergeable_interfaces_sym.
Qed.

Fixpoint find_label (c : code) (l : label) : option Z :=
  let fix aux c o :=
      match c with
      | [] => None
      | ILabel l' :: c' =>
        if Nat.eqb l l' then
          Some o
        else
          aux c' (1 + o)%Z
      | _ :: c' =>
        aux c' (1 + o)%Z
      end
  in aux c 0%Z.

Definition find_label_in_procedure G (pc : Pointer.t) (l : label) : option Pointer.t :=
  match getm (genv_procedures G) (Pointer.component pc) with
  | Some C_procs =>
    match getm C_procs (Pointer.block pc) with
    | Some P_code =>
      match find_label P_code l with
      | Some offset => Some (Pointer.component pc, Pointer.block pc, offset)
      | None => None
      end
    | None => None
    end
  | None => None
  end.

Fixpoint find_label_in_component_helper
         G (procs: list (Block.id * code))
         (pc: Pointer.t) (l: label) : option Pointer.t :=
  match procs with
  | [] => None
  | (p_block,p_code) :: procs' =>
    match find_label_in_procedure G (Pointer.component pc, p_block, 0%Z) l with
    | None => find_label_in_component_helper G procs' pc l
    | Some ptr => Some ptr
    end
  end.

Definition find_label_in_component G (pc : Pointer.t) (l : label) : option Pointer.t :=
  match getm (genv_procedures G) (Pointer.component pc) with
  | Some C_procs =>
    find_label_in_component_helper G (elementsm C_procs) pc l
  | None => None
  end.

Lemma find_label_in_procedure_guarantees:
  forall G pc pc' l,
    find_label_in_procedure G pc l = Some pc' ->
    Pointer.component pc = Pointer.component pc' /\
    Pointer.block pc = Pointer.block pc'.
Proof.
  intros G pc pc' l Hfind.
  unfold find_label_in_procedure in Hfind.
  destruct (getm (genv_procedures G) (Pointer.component pc)) as [procs|];
    try discriminate.
  destruct (getm procs (Pointer.block pc)) as [code|];
    try discriminate.
  destruct (find_label code l) as [offset|];
    try discriminate.
  destruct pc'. destruct p.
  inversion Hfind. subst.
  split; reflexivity.
Qed.

Lemma find_label_in_procedure_1:
  forall G pc pc' l,
    find_label_in_procedure G pc l = Some pc' ->
    Pointer.component pc = Pointer.component pc'.
Proof.
  eapply find_label_in_procedure_guarantees.
Qed.

Lemma find_label_in_procedure_program_link_left:
  forall {c pc},
    Pointer.component pc \notin domm (prog_interface c) ->
  forall {p},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
  forall {l},
    find_label_in_procedure (prepare_global_env (program_link p c)) pc l =
    find_label_in_procedure (prepare_global_env p) pc l.
Proof.
  (* RB: Note the proof strategy for all these lemmas is remarkably similar.
     It may be worthwhile to refactor it and/or its intermediate steps. *)
  intros c pc Hnotin p Hwfp Hwfc Hlinkable Hmains l.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable Hmains).
  unfold find_label_in_procedure, global_env_union; simpl.
  rewrite unionmE.
  assert (HNone : (genv_procedures (prepare_global_env c)) (Pointer.component pc) = None)
    by (apply /dommPn; rewrite domm_genv_procedures; done).
  rewrite HNone.
  destruct ((genv_procedures (prepare_global_env p)) (Pointer.component pc)) eqn:Hcase;
    by rewrite Hcase.
Qed.

Lemma find_label_in_component_helper_guarantees:
  forall G procs pc pc' l,
    find_label_in_component_helper G procs pc l = Some pc' ->
    Pointer.component pc = Pointer.component pc'.
Proof.
  intros G procs pc pc' l Hfind.
  induction procs.
  - discriminate.
  - simpl in *.
    destruct a.
    destruct (find_label_in_procedure
                G (Pointer.component pc, i, 0%Z) l)
             eqn:Hfind'.
    + apply find_label_in_procedure_1 in Hfind'.
      simpl in *. inversion Hfind. subst. auto.
    + apply IHprocs; auto.
Qed.

Lemma find_label_in_component_1:
  forall G pc pc' l,
    find_label_in_component G pc l = Some pc' ->
    Pointer.component pc = Pointer.component pc'.
Proof.
  intros G pc pc' l Hfind.
  unfold find_label_in_component in Hfind.
  destruct (getm (genv_procedures G) (Pointer.component pc)) as [procs|];
    try discriminate.
  eapply find_label_in_component_helper_guarantees in Hfind; auto.
Qed.

Lemma find_label_in_component_program_link_left:
  forall {c pc},
    Pointer.component pc \notin domm (prog_interface c) ->
  forall {p},
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
  forall {l},
    find_label_in_component (prepare_global_env (program_link p c)) pc l =
    find_label_in_component (prepare_global_env p) pc l.
Proof.
  intros c pc Hnotin p Hwfp Hwfc Hlinkable Hmains l.
  rewrite (prepare_global_env_link Hwfp Hwfc Hlinkable Hmains).
  unfold find_label_in_component. unfold global_env_union at 1. simpl.
  rewrite unionmE.
  assert (HNone : (genv_procedures (prepare_global_env c)) (Pointer.component pc) = None)
    by (apply /dommPn; rewrite domm_genv_procedures; done).
  rewrite HNone.
  destruct ((genv_procedures (prepare_global_env p)) (Pointer.component pc))
    as [procs |] eqn:Hcase;
    rewrite Hcase.
  - simpl.
    (* Inlined is the corresponding lemma on find_label_in_component_helper. *)
    induction (elementsm procs) as [| [p_block code] elts IHelts];
      first reflexivity.
    unfold find_label_in_component_helper; simpl.
    assert (Hnotin' : Pointer.component (Pointer.component pc, p_block, 0%Z)
                      \notin domm (prog_interface c)).
      by done.
    rewrite <- (prepare_global_env_link Hwfp Hwfc Hlinkable Hmains).
    rewrite (find_label_in_procedure_program_link_left Hnotin' Hwfp Hwfc Hlinkable Hmains).
    fold find_label_in_component_helper.
    rewrite <- IHelts.
    rewrite <- (prepare_global_env_link Hwfp Hwfc Hlinkable Hmains).
    reflexivity.
  - reflexivity.
Qed.

(* RB: Unified presentation of linkable + linkable_mains, to be used as needed
   around the development? *)
Lemma execution_invariant_to_linking:
  forall p c1 c2 pc instr,
    linkable (prog_interface p) (prog_interface c1) ->
    linkable (prog_interface p) (prog_interface c2) ->
    linkable_mains p c1 ->
    linkable_mains p c2 ->
    well_formed_program p ->
    well_formed_program c1 ->
    well_formed_program c2 ->
    Pointer.component pc \in domm (prog_interface p) ->
    executing (prepare_global_env (program_link p c1)) pc instr ->
    executing (prepare_global_env (program_link p c2)) pc instr.
Proof.
  intros p c1 c2 pc instr Hlinkable1 Hlinkable2 Hmains1 Hmains2 Hwf Hwf1 Hwf2 Hpc Hexec.
  inversion Hexec as [procs [proc [Hgenv_procs [Hprocs_proc [Hoffset Hproc_instr]]]]].
  exists procs, proc.
  split; [| split; [| split]];
    [| assumption | assumption | assumption].
  assert (Pointer.component pc \notin domm (prog_interface c1)) as Hcc1.
  {
    inversion Hlinkable1 as [_ Hdisjoint]. apply /fdisjointP. apply Hdisjoint. assumption.
  }
  assert (Pointer.component pc \notin domm (prog_interface c2)) as Hcc2.
  {
    inversion Hlinkable2 as [_ Hdisjoint]. apply /fdisjointP. apply Hdisjoint. assumption.
  }
  rewrite (genv_procedures_program_link_left_notin Hcc1 Hwf Hwf1 Hlinkable1 Hmains1) in Hgenv_procs.
  rewrite (genv_procedures_program_link_left_notin Hcc2 Hwf Hwf2 Hlinkable2 Hmains2).
  assumption.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem.
From DiSeL Require Import Rely Actions Injection Process Always HoareTriples.
From DiSeL Require Import InferenceRules InductiveInv While.
From DiSeL Require Import SeqLib CalculatorProtocol CalculatorInvariant.

Obligation Tactic := Tactics.program_simpl.

Section CalculatorRecieve.

Variable l : Label.

Variable f : input -> option nat.
Variable prec : input -> bool.

Variable cs: seq nid.
Variable cls : seq nid.
(* All nodes *)
Notation nodes := (cs ++ cls).
(* All nodes are unique *)
Hypothesis Huniq : uniq nodes.

(* Protocol and its transitions *)

Notation cal := (cal_with_inv l f prec cs cls).
Notation sts := (snd_trans cal).
Notation rts := (rcv_trans cal).

Notation W := (mkWorld cal).

(* Variable d : dstatelet. *)
(* Hypothesis C : coh cal d. *)
(* Check proj2 C. *)
(* Check cal_inv_resp _ _ _ _ _ _ _ _ _ _ _ _ (proj1 C)(proj2 C). *)

Variable cl : nid.
Hypothesis  Hc : cl \in cls.

Program Definition tryrecv_resp_act := act (@tryrecv_action_wrapper W cl
      (fun k _ t b => (k == l) && (t == resp)) _).
Next Obligation. by case/andP:H=>/eqP->; rewrite domPt inE/=. Qed.

Notation loc i := (getLocal cl (getStatelet i l)).
Notation st := (ptr_nat 1).

Export CalculatorProtocol.

(* The following spec relates outstanding requests in
   pre/postconditions and also ensures that we've got the right
   answer. *)
Program Definition tryrecv_resp :
  {rs : reqs}, DHT [cl, W]
  (fun i => loc i = st :-> rs,
   fun (r : option perm) m =>
     match r with
     | Some (from, _, ms) =>
       let v := head 0 ms in
       let args := behead ms in
       exists rs' : reqs,
       [/\ loc m = st :-> rs',
        perm_eq rs ((cl, from, args) :: rs') &
        f args = Some v]
     | None => loc m = st :-> rs
     end)
  := Do tryrecv_resp_act.
Next Obligation.
apply: ghC=>i1 rs L1 C.
apply: act_rule=>i2 R1/=; split; first by case: (rely_coh R1).
move=>r i3 i4[Sf]S R3/=; rewrite -(rely_loc' l R1) in L1.
case: Sf=>_ _ _ _ /(_ l); clear C=>C.
case: S=>C2[|[l'][mid][tms][from][rt][pf][][E]Hin E1 Hw/=].
- by case=>?->Z; subst i3; rewrite (rely_loc' _ R3).
case/andP=>/eqP Z G; subst l'; set d := (getStatelet i2 l) in C E pf Hw *.
move=>Z->{r}; subst i3.
move: rt pf (coh_s l C2) Hin E1 Hw R3 C G.
rewrite prEq=>rt pf cohs Hin E1 Hw R3 C G.
case: Hin=>/=Z; do?[subst rt|case: Z]=>//Z; subst rt.
simpl in E1, Hw, R3; clear G.
rewrite /cr_wf/= in Hw.
case: tms E E1 R3 Hw=>t tms/= E E1 R3 Hw; subst t.
have A1: exists s', dsoup d = mid \\-> (Msg (TMsg resp tms) from cl true) \+ s'.
+ by move/esym/um_eta2: E=>->; exists (free (dsoup d) mid).
case: A1=>s' Es.

(* Some auxiliary facts *)
have Y : tms = head 0 tms :: behead tms.
- suff M: exists x xs, tms = x::xs by case:M=>x [xs]E'; subst tms.
  by case/andP: Hw=>_; case: (tms)=>//x xs _; exists x, xs.
have Y' : from \in cs.
- case: (proj1 C)=>Cs _ _ _. case: Cs=>Vs/(_ mid)Cs.
  rewrite Es in Vs Cs; move: (findPtUn Vs)=>Ez.
  by move: (Cs _ Ez)=>/=; rewrite/cohMsg/==>H; case: H.

(* Using the invariant *)
move: ((proj2 C) (proj1 C) cl from (head 0 tms) (behead tms) mid s' Hc Y')=>//=.
rewrite -!Y; move/(_ Es)=>F.
rewrite Y in Hw.

(* Proving the change in permissions *)
have X: (cl, from, (behead tms)) \in rs.
- by case/andP: Hw; rewrite (getStK (proj1 cohs) L1).
have P1: valid (dstate d) by apply: (cohVl C).
have P2: valid i2 by apply: (cohS (proj2 (rely_coh R1))).
have P3: l \in dom i2 by rewrite -(cohD(proj2(rely_coh R1)))domPt inE/=.
rewrite (rely_loc' _ R3)/= locE// /cr_step (getStK (proj1 cohs) L1)/=.
clear R3 Hw P1 P2 P3; exists (remove_elem rs (cl, from, (behead tms))).
move: (remove_elem_in rs (cl, from, (behead tms))); rewrite X.
by rewrite perm_sym=>H.
Qed.

Definition receive_loop_cond (res : option nat) := res == None .

Definition receive_loop_inv (rs : reqs) :=
  fun r i =>
    match r with
     | Some v =>
       exists (rs' : reqs) from args ,
       [/\ loc i = st :-> rs',
        perm_eq rs ((cl, from, args) :: rs') &
        f args = r]
     | None => loc i = st :-> rs
    end.

Program Definition receive_loop' :
  {(rs : reqs)}, DHT [cl, W]
  (fun i => loc i = st :-> rs,
   fun (res : option nat) m =>
     exists (rs' : reqs) v from args ,
       [/\ res = Some v, loc m = st :-> rs',
        perm_eq rs ((cl, from, args) :: rs') &
        f args = res]) :=
  Do _ (@while cl W _ _ receive_loop_cond receive_loop_inv _
        (fun r => Do _ (
           r <-- tryrecv_resp;
           match r with
           | Some (_, _, msg) => ret _ _ (Some (head 0 msg))
           | None => ret _ _ None
           end)) None).

Next Obligation. by apply: with_spec x. Defined.
Next Obligation.
by move:H; rewrite /receive_loop_inv (rely_loc' _ H0).
Qed.
Next Obligation.
apply:ghC=>i1 rs[];rewrite /receive_loop_cond.
move/eqP=>->/=E1 C1; apply: step; apply: (gh_ex (g:=rs)).
apply: call_rule=>//={r}res i2; case: res; last first.
- move=>E2 C; apply:ret_rule=>i3 R2.
  by rewrite /receive_loop_inv (rely_loc' _ R2).
case; case=>from v msg[rs'][E2]P F C2.
apply:ret_rule=>i3 R2; rewrite /receive_loop_inv (rely_loc' _ R2).
by exists rs', from, (behead msg).
Qed.

Next Obligation.
apply: ghC=>i rs E1 C1; apply: (gh_ex (g:=rs)).
apply: call_rule=>//res m[].
rewrite /receive_loop_cond; case: res=>//=v _.
move=>[rs'][from][args][E2]Hp F C2.
by exists rs', v, from, args.
Qed.

(* Blocking receive-loop that always returns a result (but may not
   terminate) *)
Program Definition blocking_receive_resp :
  {(rs : reqs)}, DHT [cl, W]
  (fun i => loc i = st :-> rs,
   fun (res :  nat) m =>
     exists (rs': reqs) from args ,
       [/\ loc m = st :-> rs',
        perm_eq rs ((cl, from, args) :: rs') &
        f args = Some res]) :=
  Do _ (r <-- receive_loop';
        match r with
        | Some res => ret _ _ res
        | None => ret _ _ 0
        end).
Next Obligation.
apply: ghC=>i rs E1 C1; apply: step; apply: (gh_ex (g:=rs)).
apply: call_rule=>//res i2[rs'][v][from][args][Z]E2 H1 H2.
subst res=>C2; apply: ret_rule=>i3 R2.
by exists rs', from, args; rewrite (rely_loc' _ R2).
Qed.

(* Simple send_transition *)

Definition client_send_trans :=
  ProtocolWithInvariant.snd_transI (s2 l f prec cs cls).

Program Definition send_request server args :=
  act (@send_action_wrapper W cal cl l (prEq cal) client_send_trans _
                            args server).
Next Obligation. by rewrite InE; right; rewrite InE. Qed.

Program Definition compute_f (server : nid) (args: seq nat) :
  DHT [cl, W]
  (fun i =>
     [/\ loc i = st :-> ([::] : reqs),
      prec args & server \in cs],
   fun (res : nat) m => loc m = st :-> ([::] : reqs) /\
                        f args = Some res) :=
  Do _ (send_request server args;;
        blocking_receive_resp).
Next Obligation.
move=>i1/=[E1 H2 H3].
apply: step; apply: act_rule=>i2 R1.
case: (rely_coh R1)=>_ C2.
have C': coh cal (getStatelet i2 l) by case: C2=>_ _ _ _/(_ l);rewrite prEq.
split=>//=.
- split=>//=.
  + by split=>//; case: C'.
  + rewrite/Actions.can_send -(cohD C2)/=domPt inE/= eqxx.
    by rewrite mem_cat Hc orbC.
  + rewrite/Actions.filter_hooks umfilt0=>???.
    move => F.
    apply sym_eq in F.
    move: F.
    by move/find_some; rewrite dom0.
move=>y i3 i4[S]/=;case=>Z[b]/=[F]E3 R3; subst y.
case: F=>/=F; subst b i3=>/=.
rewrite -(rely_loc' _ R1) in E1.
rewrite (getStK _ E1) in R3.
apply: (gh_ex (g:=[:: (cl, server, args)])).
apply: call_rule=>//.
- move=>C4; rewrite (rely_loc' _ R3) locE//; last by apply: (cohVl C').
  + by rewrite -(cohD C2) domPt inE/=.
  by apply: (cohS C2).
clear R3=>v i5[rs'][from][args'][E5]P5 R C.
suff X: args = args' /\ rs' = [::] by case: X=>Z X; subst args' rs'.
suff X': rs' = [::].
- subst rs'; split=>//; move/perm_mem: P5=>P5.
  move/P5: (cl, server, args).
  by rewrite inE eqxx inE/==>/esym/eqP; case=>_->.
by case/perm_size: P5=>/esym/size0nil.
Qed.

(**************************************************)
(*
Overall Implementation effort:

5 person-hours

*)
(**************************************************)

(* More elaborated client program, compting a list of values *)

Definition compute_list_spec server ys :=
  forall (xs_acc : (seq input) * (seq (input * nat))),
  DHT [cl, W]
   (fun i =>
     let: (xs, acc) := xs_acc in
     [/\ loc i = st :-> ([::] : reqs),
      all prec xs,
      all (fun e => f e.1 == Some e.2) acc,
      ys = map fst acc ++ xs &
      server \in cs],
   fun (res : seq (input * nat)) m =>
     [/\ loc m = st :-> ([::] : reqs),
      all (fun e => f e.1 == Some e.2) res &
      ys = map fst res]).

Program Definition compute_list_f server (xs : seq input) :
  DHT [cl, W]
   (fun i =>
     [/\ loc i = st :-> ([::] : reqs),
      all prec xs &
      server \in cs],
   fun (res : seq (input * nat)) m =>
     [/\ loc m = st :-> ([::] : reqs),
      all (fun e => f e.1 == Some e.2) res &
      xs = map fst res])
  :=
  Do (ffix (fun (rec : compute_list_spec server xs) xsa =>
    Do _ (let: (xs, acc) := xsa in
          if xs is x :: xs'
          then r <-- compute_f server x;
               let: acc' := rcons acc (x, r) in
               rec (xs', acc')
          else ret _ _ acc)) (xs, [::])).

Next Obligation.
move=>i1/=[L1]; move:l0 l4=>zs acc H1 H2 H3 H4.
case: zs H1 H3=>//=[_|z zs/andP[H1]H5] H3.
- by rewrite cats0 in H3;
  apply: ret_rule=>i2 R1; split=>//; rewrite ?(rely_loc' _ R1)//.
apply: step; apply: call_rule=>//r i2[L2]F C2.
apply: call_rule=>//_; split=>//; first by rewrite all_rcons/= F eqxx.
by rewrite map_rcons/= -cats1 -catA cat_cons/=.
Qed.

Next Obligation.
by move=>i1/=[L1]??; apply: call_rule=>//; rewrite cats0.
Qed.

End CalculatorRecieve.


Require Import Lia.
Require Import RelationClasses.
Require Import Program.

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

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

Require Import Time.
From PromisingLib Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import BoolMap.
Require Import Promises.
Require Import Global.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Require Import MemoryProps.
Require Import Certify.
Require Import CurrentCertify.
Require Import PFConsistent.

Set Implicit Arguments.

Definition owned_future_mem_loc loc: Memory.t -> Memory.t -> Prop :=
  fun mem0 mem1 =>
    forall from to val released na
           (GET: Memory.get loc to mem1 = Some (from, Message.message val released na)),
      Memory.get loc to mem0 = Some (from, Message.message val released na)
.

Global Program Instance owned_future_mem_loc_PreOrder loc:
  PreOrder (owned_future_mem_loc loc).
Next Obligation.
Proof.
  ii. auto.
Qed.
Next Obligation.
Proof.
  ii. eapply H; auto.
Qed.

Definition owned_future_global_loc loc: Global.t -> Global.t -> Prop :=
  fun gl0 gl1 =>
    (<<MEM: owned_future_mem_loc loc gl0.(Global.memory) gl1.(Global.memory)>>) /\
      (<<PROM: gl1.(Global.promises) loc = gl0.(Global.promises) loc>>)
.

Global Program Instance owned_future_global_loc_PreOrder loc:
  PreOrder (owned_future_global_loc loc).
Next Obligation.
Proof.
  unfold owned_future_global_loc. ii. splits.
  { refl. }
  { auto. }
Qed.
Next Obligation.
Proof.
  unfold owned_future_global_loc. ii. des. splits.
  { etrans; eauto. }
  { etrans; eauto. }
Qed.

Definition owned_future_global_promises
           (prom: BoolMap.t) (gl0 gl1: Global.t): Prop :=
  forall loc (OWNED: prom loc = true), owned_future_global_loc loc gl0 gl1.

Global Program Instance owned_future_global_promises_PreOrder prom:
  PreOrder (owned_future_global_promises prom).
Next Obligation.
Proof.
  ii. refl.
Qed.
Next Obligation.
Proof.
  ii. etrans; eauto.
Qed.

Lemma owned_future_global_promises_mon
      prom0 prom1 gl0 gl1
      (FUTURE: owned_future_global_promises prom1 gl0 gl1)
      (LE: BoolMap.le prom0 prom1)
  :
  owned_future_global_promises prom0 gl0 gl1.
Proof.
  ii. eapply FUTURE; eauto.
Qed.

Lemma local_reserve_step_owned_future
      own
      loc from to lc0 gl0 lc1 gl1
      (STEP: Local.reserve_step lc0 gl0 loc from to lc1 gl1):
  owned_future_global_promises
    own
    gl0 gl1.
Proof.
  inv STEP; ss. inv RESERVE. ii. rr. splits; ss.
  ii. erewrite Memory.add_o in GET; eauto. des_ifs.
Qed.

Lemma local_cancel_step_owned_future
      own
      loc from to lc0 gl0 lc1 gl1
      (STEP: Local.cancel_step lc0 gl0 loc from to lc1 gl1):
  owned_future_global_promises
    own
    gl0 gl1.
Proof.
  inv STEP; ss. inv CANCEL. ii. rr. splits; ss.
  ii. erewrite Memory.remove_o in GET; eauto. des_ifs.
Qed.

Lemma local_program_step_owned_future
      own
      e lc0 gl0 lc1 gl1
      (STEP: Local.program_step e lc0 gl0 lc1 gl1):
  (<<FUTURE: owned_future_global_promises
               own
               gl0 gl1>>) \/
    (exists loc from to val released ord,
        (<<ACCESS: ThreadEvent.is_writing e = Some (loc, from, to, val, released, ord)>>) /\
          (<<RACE: own loc = true>>)).
Proof.
  inv STEP; ss.
  { left. r. refl. }
  { left. r. refl. }
  { destruct (own loc) eqn:RACE.
    { right. esplits; eauto. }
    { left. ii. assert (NEQ: loc0 <> loc).
      { ii. subst. rewrite RACE in *. ss. }
      inv LOCAL. econs; ss.
      { ii. erewrite Memory.add_o in GET; eauto. des_ifs. ss. des; clarify. }
      { inv FULFILL; ss. inv REMOVE. inv GREMOVE.
        rr. erewrite ! loc_fun_add_spec. condtac; subst; ss.
      }
    }
  }
  { destruct (own loc) eqn:RACE.
    { right. esplits; eauto. }
    { left. ii. assert (NEQ: loc0 <> loc).
      { ii. subst. rewrite RACE in *. ss. }
      inv LOCAL1. inv LOCAL2. econs; ss.
      { ii. erewrite Memory.add_o in GET0; eauto.
        destruct (loc_ts_eq_dec (loc0, to) (loc, tsw)); ss. des; clarify.
      }
      { inv FULFILL; ss. inv REMOVE. inv GREMOVE.
        rr. erewrite ! loc_fun_add_spec. condtac; subst; ss.
      }
    }
  }
  { left. inv LOCAL; ss. ii. split; ss. }
  { left. inv LOCAL; ss. ii. split; ss. }
  { left. r. refl. }
  { left. r. refl. }
  { left. r. refl. }
  { left. r. refl. }
Qed.

Lemma program_step_owned_future
      own
      e lang (th1 th2: Thread.t lang)
      (STEP: Thread.program_step e th1 th2):
  (exists loc from to val released ord,
      (<<ACCESS: ThreadEvent.is_writing e = Some (loc, from, to, val, released, ord)>>) /\
        (<<RACE: own loc = true>>)) \/
    (<<FUTURE: owned_future_global_promises
                 own
                 (th1.(Thread.global)) (th2.(Thread.global))>>).
Proof.
  inv STEP. hexploit local_program_step_owned_future; eauto.
  i. des; cycle 1.
  { left. destruct e; ss; clarify.
    { esplits; eauto. }
    { esplits; eauto. }
  }
  right. esplits; eauto.
Qed.

Lemma pf_step_owned_future
      own
      lang (th1 th2: Thread.t lang)
      (STEP: pstep (@Thread.step lang) (ThreadEvent.is_pf /1\ non_sc) th1 th2):
  (exists loc from to val released ord th2' e',
      (<<STEP: Thread.step e' th1 th2'>>) /\
        (<<ACCESS: ThreadEvent.is_writing e' = Some (loc, from, to, val, released, ord)>>) /\
        (<<RACE: own loc = true>>)) \/
    ((<<FUTURE: owned_future_global_promises
                  own
                  (th1.(Thread.global)) (th2.(Thread.global))>>)).
Proof.
  inv STEP. des. inv STEP0; ss.
  { right. inv LOCAL; ss.
    eapply local_cancel_step_owned_future; eauto.
  }
  { hexploit program_step_owned_future.
    { econs; eauto. }
    i. des.
    { left. esplits; eauto. }
    right. esplits; eauto.
  }
Qed.

Lemma pf_steps_owned_future
      own
      lang (th1 th2: Thread.t lang)
      (STEPS: rtc (pstep (@Thread.step lang) (ThreadEvent.is_pf /1\ non_sc)) th1 th2):
  (exists th1' th2' e' loc from to val released ord,
      (<<STEPS: rtc (pstep (@Thread.step lang) (ThreadEvent.is_pf /1\ non_sc)) th1 th1'>>) /\
        (<<STEP: Thread.step e' th1' th2'>>) /\
        (<<ACCESS: ThreadEvent.is_writing e' = Some (loc, from, to, val, released, ord)>>) /\
        (<<RACE: own loc = true>>)) \/
    ((<<FUTURE: owned_future_global_promises
                  own
                  (th1.(Thread.global)) (th2.(Thread.global))>>)).
Proof.
  induction STEPS; i.
  { right. splits; auto. refl. }
  hexploit pf_step_owned_future; eauto. i. des.
  { left. esplits; eauto. }
  { left. esplits; eauto. }
  { left. esplits.
    { econs 2; eauto. }
    { eauto. }
    { eauto. }
    { eauto. }
  }
  { right. r. etrans; eauto. }
Qed.

Lemma promise_step_owned_future
      own
      lang (th1 th2: Thread.t lang) loc
      (STEP: Thread.step (ThreadEvent.promise loc) th1 th2)
      (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
      (GL_WF1: Global.wf (Thread.global th1))
      (CONS: rtc_consistent th2)
  :
  (exists th1' th2' e',
      (<<STEPS: rtc (pstep (@Thread.step lang) (ThreadEvent.is_pf /1\ non_sc)) th1 th1'>>) /\
        (<<STEP: Thread.step e' th1' th2'>>) /\
        ((<<FAILURE: ThreadEvent.get_machine_event e' = MachineEvent.failure>>) \/
           (exists loc from to val released ord,
               (<<ACCESS: ThreadEvent.is_writing e' = Some (loc, from, to, val, released, ord)>>) /\
                 (<<RACE: own loc = true>>)))) \/
    ((<<FUTURE: owned_future_global_promises
                  own
                  (th1.(Thread.global)) (th2.(Thread.global))>>) /\
       (<<NOWN: own loc = false>>)).
Proof.
  destruct (own loc) eqn:RACE.
  { left.
    rr in CONS. des.
    eapply CurrentCertify.rtc_step_consistent_ceritfy_racy_promise in STEP.
    2:{ eauto. }
    2:{ eauto. }
    2:{ eapply rtc_implies; [|eauto]. i. inv H. econs; eauto. }
    2:{ eauto. }
    inv STEP.
    { hexploit pf_steps_owned_future; eauto. i. des.
      { esplits; eauto. right. esplits; eauto. }
      { esplits; eauto. }
    }
    { esplits; eauto. right. esplits; eauto. ss. }
  }
  { right.
    inv STEP; inv LOCAL; ss. inv LOCAL0; ss. esplits; eauto.
    ii. rr. splits; ss. inv PROMISE. inv ADD. inv GADD.
    erewrite loc_fun_add_spec. des_ifs.
  }
Qed.

Lemma step_owned_future
      own
      lang (th1 th2: Thread.t lang) e
      (STEP: Thread.step e th1 th2)
      (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
      (GL_WF1: Global.wf (Thread.global th1))
      (CONS: rtc_consistent th2)
  :
  (exists th1' th2' e',
      (<<STEPS: rtc (pstep (@Thread.step lang) (ThreadEvent.is_pf /1\ non_sc)) th1 th1'>>) /\
        (<<STEP: Thread.step e' th1' th2'>>) /\
        ((<<FAILURE: ThreadEvent.get_machine_event e' = MachineEvent.failure>>) \/
           (exists loc from to val released ord,
               (<<ACCESS: ThreadEvent.is_writing e' = Some (loc, from, to, val, released, ord)>>) /\
                 (<<RACE: own loc = true>>)))) \/
    ((<<FUTURE: owned_future_global_promises
                  own
                  (th1.(Thread.global)) (th2.(Thread.global))>>)).
Proof.
  inv STEP.
  { inv LOCAL.
    { hexploit promise_step_owned_future; eauto. i. des.
      { left. esplits; eauto. }
      { left. esplits; eauto. right. esplits; eauto. }
      { right. esplits; eauto. }
    }
    { right. esplits; eauto. eapply local_reserve_step_owned_future; eauto. }
    { right. esplits; eauto. eapply local_cancel_step_owned_future; eauto. }
  }
  { hexploit program_step_owned_future; eauto.
    { econs; eauto. }
    i. des; ss.
    { left. esplits; eauto. right. esplits; eauto. }
    { right. esplits; eauto. }
  }
Qed.

Lemma local_internal_step_owned_future
      e lc0 gl0 lc1 gl1
      (STEP: Local.internal_step e lc0 gl0 lc1 gl1)
  :
  owned_future_global_promises
    (BoolMap.minus gl0.(Global.promises) lc0.(Local.promises))
    gl0 gl1.
Proof.
  inv STEP.
  { inv LOCAL. inv PROMISE. ii; ss. split; ss.
    inv ADD. inv GADD. rewrite loc_fun_add_spec.
    unfold BoolMap.minus, andb, negb in OWNED. des_ifs.
  }
  { inv LOCAL. inv RESERVE. ii. split; ss.
    ii. erewrite Memory.add_o in GET; eauto. des_ifs.
  }
  { inv LOCAL. inv CANCEL. ii. split; ss.
    ii. erewrite Memory.remove_o in GET; eauto. des_ifs.
  }
Qed.

Lemma internal_step_owned_future
      lang (th1 th2: Thread.t lang)
      (STEP: Thread.internal_step th1 th2)
  :
  owned_future_global_promises
    (BoolMap.minus th1.(Thread.global).(Global.promises) th1.(Thread.local).(Local.promises))
    (th1.(Thread.global)) (th2.(Thread.global)).
Proof.
  inv STEP. eapply local_internal_step_owned_future in LOCAL; ss.
Qed.

Lemma rtc_internal_step_owned_future
      lang (th1 th2: Thread.t lang)
      (STEPS: rtc (@Thread.internal_step _) th1 th2)
  :
  owned_future_global_promises
    (BoolMap.minus th1.(Thread.global).(Global.promises) th1.(Thread.local).(Local.promises))
    (th1.(Thread.global)) (th2.(Thread.global)).
Proof.
  induction STEPS; i.
  { refl. }
  { hexploit internal_step_owned_future; eauto. i. etrans; eauto.
    inv H. ss. apply Local.internal_step_promises_minus in LOCAL.
    rewrite LOCAL. auto.
  }
Qed.


(* This file gives two different implementations of the blockchain
execution layer defined in Blockchain.v. Both versions are execution
layers using std++'s finite maps and are thus relatively
efficient. They differ in execution order: one uses a depth-first
execution order, while the other uses a breadth-first execution order. *)

From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import BoundedN.
From ConCert.Execution Require Import ChainedList.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Utils Require Import Automation.
From ConCert.Utils Require Import Extras.
From ConCert.Utils Require Import RecordUpdate.
From Coq Require Import ZArith.
From Coq Require Import Permutation.
From Coq Require Import List.
From Coq Require Import Psatz.

Import ListNotations.

Section LocalBlockchain.
  Local Open Scope bool.

  Context {AddrSize : N}.
  Context {DepthFirst : bool}.

  Definition ContractAddrBase : N := AddrSize / 2.

  Global Instance LocalChainBase : ChainBase :=
    {| Address := BoundedN AddrSize;
      address_eqb := BoundedN.eqb;
      address_eqb_spec := BoundedN.eqb_spec;
      address_is_contract a := (ContractAddrBase <=? BoundedN.to_N a)%N
    |}.

  Record LocalChain :=
    build_local_chain {
      lc_height : nat;
      lc_slot : nat;
      lc_fin_height : nat;
      lc_account_balances : FMap Address Amount;
      lc_contract_state : FMap Address SerializedValue;
      lc_contracts : FMap Address WeakContract;
    }.

  MetaCoq Run (make_setters LocalChain).

  Definition lc_to_env (lc : LocalChain) : Environment :=
    {| env_chain :=
          {| chain_height := lc_height lc;
            current_slot := lc_slot lc;
            finalized_height := lc_fin_height lc; |};
      env_account_balances a := with_default 0%Z (FMap.find a (lc_account_balances lc));
      env_contract_states a := FMap.find a (lc_contract_state lc);
      env_contracts a := FMap.find a (lc_contracts lc); |}.

  Global Coercion lc_to_env : LocalChain >-> Environment.

  Section ExecuteActions.
    Local Open Scope Z.

    Definition add_balance
                (addr : Address)
                (amt : Amount)
                (lc : LocalChain)
                : LocalChain :=
      let update opt := Some (amt + with_default 0 opt) in
      lc<|lc_account_balances ::= FMap.partial_alter update addr|>.

    Definition transfer_balance
                (from to : Address)
                (amount : Amount)
                (lc : LocalChain)
                : LocalChain :=
      add_balance to amount (add_balance from (-amount) lc).

    Definition get_new_contract_addr (lc : LocalChain) : option Address :=
      BoundedN.of_N (ContractAddrBase + N.of_nat (FMap.size (lc_contracts lc))).

    Definition add_contract
                (addr : Address)
                (wc : WeakContract)
                (lc : LocalChain) : LocalChain :=
      lc<|lc_contracts ::= FMap.add addr wc|>.

    Definition set_contract_state
                (addr : Address)
                (state : SerializedValue)
                (lc : LocalChain) : LocalChain :=
      lc<|lc_contract_state ::= FMap.add addr state|>.

    Definition weak_error_to_error_init
                (r : result SerializedValue SerializedValue)
                : result SerializedValue ActionEvaluationError :=
      bind_error (fun err => init_failed err) r.

    Definition weak_error_to_error_receive
                (r : result (SerializedValue * list ActionBody) SerializedValue)
                : result (SerializedValue * list ActionBody) ActionEvaluationError :=
      bind_error (fun err => receive_failed err) r.

    Definition send_or_call
                (origin : Address)
                (from to : Address)
                (amount : Amount)
                (msg : option SerializedValue)
                (lc : LocalChain)
                : result (list Action * LocalChain) ActionEvaluationError :=
      do if amount <? 0 then Err (amount_negative amount) else Ok tt;
      do if amount >? env_account_balances lc from then Err (amount_too_high amount) else Ok tt;
      match FMap.find to lc.(lc_contracts) with
      | None =>
        (* Fail if sending a message to address without contract *)
        do if address_is_contract to then Err (no_such_contract to) else Ok tt;
        match msg with
          | None => Ok ([], transfer_balance from to amount lc)
          | Some msg => Err (no_such_contract to)
        end
      | Some wc =>
        do state <- result_of_option (env_contract_states lc to) internal_error;
        let lc := transfer_balance from to amount lc in
        let ctx := build_ctx origin from to (env_account_balances lc to) amount in
        do '(new_state, new_actions) <- weak_error_to_error_receive (wc_receive wc lc ctx state msg);
        let lc := set_contract_state to new_state lc in
          Ok (map (build_act origin to) new_actions, lc)
      end.

    Definition deploy_contract
                (origin : Address)
                (from : Address)
                (amount : Amount)
                (wc : WeakContract)
                (setup : SerializedValue)
                (lc : LocalChain)
                : result (list Action * LocalChain) ActionEvaluationError :=
      do if amount <? 0 then Err (amount_negative amount) else Ok tt;
      do if amount >? env_account_balances lc from then Err (amount_too_high amount) else Ok tt;
      do contract_addr <- result_of_option (get_new_contract_addr lc) too_many_contracts;
      do match FMap.find contract_addr (lc_contracts lc) with
        | Some _ => Err internal_error
        | None => Ok tt
        end;
      let lc := transfer_balance from contract_addr amount lc in
      let ctx := build_ctx origin from contract_addr amount amount in
      do state <- weak_error_to_error_init (wc_init wc lc ctx setup);
      let lc := add_contract contract_addr wc lc in
      let lc := set_contract_state contract_addr state lc in
      Ok ([], lc).

    Local Open Scope nat.

    Definition execute_action
                (act : Action)
                (lc : LocalChain)
                : result (list Action * LocalChain) ActionEvaluationError :=
      match act with
      | build_act origin from (act_transfer to amount) =>
        send_or_call origin from to amount None lc
      | build_act origin from (act_deploy amount wc setup) =>
        deploy_contract origin from amount wc setup lc
      | build_act origin from (act_call to amount msg) =>
        send_or_call origin from to amount (Some msg) lc
      end.

    Fixpoint execute_actions
              (count : nat)
              (acts : list Action)
              (lc : LocalChain)
              (depth_first : bool)
              : result LocalChain AddBlockError :=
      match count, acts with
      | _, [] => Ok lc
      | 0, _ => Err action_evaluation_depth_exceeded
      | S count, act :: acts =>
        match execute_action act lc with
        | Ok (next_acts, lc) =>
          let acts := if depth_first
                      then next_acts ++ acts
                      else acts ++ next_acts in
          execute_actions count acts lc depth_first
        | Err act_err =>
          Err (action_evaluation_error act act_err)
        end
      end.

    Lemma transfer_balance_equiv
            (from to : Address)
            (amount : Amount)
            (lc : LocalChain)
            (env : Environment) :
      EnvironmentEquiv lc env ->
      EnvironmentEquiv
        (transfer_balance from to amount lc)
        (Blockchain.transfer_balance from to amount env).
    Proof.
      intros <-.
      apply build_env_equiv; auto.
      cbn.
      intros addr.
      unfold Amount in *.
      destruct_address_eq; subst;
        repeat
          (try rewrite FMap.find_partial_alter;
          try rewrite FMap.find_partial_alter_ne by auto;
          cbn); lia.
    Defined.

    Lemma set_contract_state_equiv addr state (lc : LocalChain) (env : Environment) :
      EnvironmentEquiv lc env ->
      EnvironmentEquiv
        (set_contract_state addr state lc)
        (Blockchain.set_contract_state addr state env).
    Proof.
      intros <-.
      apply build_env_equiv; auto.
      intros addr'.
      cbn.
      unfold set_chain_contract_state.
      destruct_address_eq.
      - subst. now rewrite FMap.find_add.
      - rewrite FMap.find_add_ne; auto.
    Defined.

    Lemma add_contract_equiv addr wc (lc : LocalChain) (env : Environment) :
      EnvironmentEquiv lc env ->
      EnvironmentEquiv
        (add_contract addr wc lc)
        (Blockchain.add_contract addr wc env).
    Proof.
      intros <-.
      apply build_env_equiv; auto.
      intros addr'.
      cbn.
      destruct_address_eq.
      - subst. now rewrite FMap.find_add.
      - rewrite FMap.find_add_ne; auto.
    Defined.

    Local Open Scope Z.
    Lemma gtb_le x y :
      x >? y = false ->
      x <= y.
    Proof.
      intros H.
      rewrite Z.gtb_ltb in H.
      apply Z.ltb_ge.
      auto.
    Defined.

    Lemma ltb_ge x y :
      x <? y = false ->
      x >= y.
    Proof.
      intros H.
      apply Z.ltb_ge in H.
      lia.
    Defined.

    Local Hint Resolve gtb_le ltb_ge : core.

    Lemma send_or_call_step origin from to amount msg act lc_before new_acts lc_after :
      send_or_call origin from to amount msg lc_before = Ok (new_acts, lc_after) ->
      act = build_act origin from (match msg with
                                  | None => act_transfer to amount
                                  | Some msg => act_call to amount msg
                                  end) ->
      ActionEvaluation lc_before act lc_after new_acts.
    Proof.
      intros sent act_eq.
      unfold send_or_call in sent.
      destruct (Z.ltb amount 0) eqn:amount_nonnegative;
        [cbn in *; congruence|].
      destruct (Z.gtb amount (env_account_balances lc_before from)) eqn:balance_enough;
        [cbn in *; congruence|].
      destruct (FMap.find to (lc_contracts lc_before)) as [wc|] eqn:to_contract.
      - (* there is a contract at destination, so do call *)
        destruct (env_contract_states _ _) as [prev_state|] eqn:prev_state_eq;
          [|cbn in *; congruence].
        cbn -[lc_to_env] in *.
        destruct (wc_receive wc _ _ _ _) as [[new_state resp_acts]|] eqn:receive;
          [|cbn in *; congruence].
        apply (eval_call origin from to amount wc msg prev_state new_state resp_acts);
          try solve [cbn in *; auto; congruence].
        + cbn in sent.
          inversion_clear sent.
          rewrite <- receive.
          auto.
        + inversion sent; subst;
            now apply set_contract_state_equiv, transfer_balance_equiv.
      - (* no contract at destination, so msg should be empty *)
        destruct (address_is_contract to) eqn:addr_format; cbn in *; try congruence.
        destruct msg; cbn in *; try congruence.
        assert (new_acts = []) by congruence; subst new_acts.
        apply (eval_transfer origin from to amount); auto.
        inversion sent; subst; now apply transfer_balance_equiv.
    Defined.

    Lemma get_new_contract_addr_is_contract_addr lc addr :
      get_new_contract_addr lc = Some addr ->
      address_is_contract addr = true.
    Proof.
      intros get.
      unfold get_new_contract_addr in get.
      pose proof (BoundedN.of_N_some get) as eq.
      destruct addr as [addr prf].
      cbn in *; rewrite eq.
      match goal with
      | [|- context[N.leb ?a ?b = true]] => destruct (N.leb_spec a b); auto; lia
      end.
    Defined.

    Local Hint Resolve get_new_contract_addr_is_contract_addr : core.
    Lemma deploy_contract_step origin from amount wc setup act lc_before new_acts lc_after :
      deploy_contract origin from amount wc setup lc_before = Ok (new_acts, lc_after) ->
      act = build_act origin from (act_deploy amount wc setup) ->
      ActionEvaluation lc_before act lc_after new_acts.
    Proof.
      intros dep act_eq.
      unfold deploy_contract in dep.
      destruct (Z.ltb amount 0) eqn:amount_nonnegative;
        [cbn in *; congruence|].
      destruct (Z.gtb amount (env_account_balances lc_before from)) eqn:balance_enough;
        [cbn in *; congruence|].
      destruct (get_new_contract_addr lc_before) as [contract_addr|] eqn:new_contract_addr;
        [|cbn in *; congruence].
      cbn -[incoming_txs] in dep.
      destruct (FMap.find _ _) eqn:no_contracts; [cbn in *; congruence|].
      destruct (wc_init _ _ _ _) as [state|] eqn:recv; [|cbn in *; congruence].
      cbn in dep.
      assert (new_acts = []) by congruence; subst new_acts.
      apply (eval_deploy origin from contract_addr amount wc setup state); eauto.
      inversion dep; subst lc_after.
      now apply set_contract_state_equiv, add_contract_equiv, transfer_balance_equiv.
    Defined.

    Local Hint Resolve send_or_call_step deploy_contract_step : core.
    Lemma execute_action_step
          (act : Action)
          (new_acts : list Action)
          (lc_before : LocalChain)
          (lc_after : LocalChain) :
      execute_action act lc_before = Ok (new_acts, lc_after) ->
      ActionEvaluation lc_before act lc_after new_acts.
    Proof.
      intros exec.
      unfold execute_action in exec.
      destruct act as [orig from body].
      destruct body as [to amount|to amount msg|amount wc setup]; eauto.
    Defined.

    Hint Constructors ChainStep : core.
    Hint Constructors ChainedList : core.
    Hint Unfold ChainTrace : core.

    Lemma execute_actions_trace count acts (lc lc_final : LocalChain) df
          (trace : ChainTrace empty_state (build_chain_state lc acts)) :
      execute_actions count acts lc df = Ok lc_final ->
      ChainTrace empty_state (build_chain_state lc_final []).
    Proof.
      revert acts lc lc_final trace.
      induction count as [| count IH]; intros acts lc lc_final trace exec; cbn in *.
      - destruct acts; congruence.
      - destruct acts as [|x xs]; try congruence.
        destruct (execute_action x lc) as [[new_acts lc_after]|] eqn:exec_once;
          cbn in *; try congruence.
        set (step := execute_action_step _ _ _ _ exec_once).
        refine (IH _ _ _ _ exec).
        destruct df.
        + (* depth-first case *)
          eauto.
        + (* breadth-first case. Insert permute step. *)
          assert (Permutation (new_acts ++ xs) (xs ++ new_acts)) by perm_simplify.
          cut (ChainTrace
                empty_state
                (build_chain_state lc_after (new_acts ++ xs))); eauto.
          intros.
          econstructor; eauto.
          constructor; eauto.
          constructor; eauto.
    Defined.
  End ExecuteActions.

  Definition lc_initial : LocalChain :=
    {| lc_height := 0;
      lc_slot := 0;
      lc_fin_height := 0;
      lc_account_balances := FMap.empty;
      lc_contract_state := FMap.empty;
      lc_contracts := FMap.empty; |}.

  Record LocalChainBuilder :=
    build_local_chain_builder {
      lcb_lc : LocalChain;
      lcb_trace : ChainTrace empty_state (build_chain_state lcb_lc []);
    }.

  Definition lcb_initial : LocalChainBuilder :=
    {| lcb_lc := lc_initial; lcb_trace := clnil |}.

  Definition validate_header (header : BlockHeader) (chain : Chain) : bool :=
    (block_height header =? S (chain_height chain))
    && (current_slot chain <? block_slot header)
    && (finalized_height chain <=? block_finalized_height header)
    && (block_finalized_height header <? block_height header)
    && address_not_contract (block_creator header)
    && (block_reward header >=? 0)%Z.

  Lemma validate_header_valid header chain :
    validate_header header chain = true ->
    IsValidNextBlock header chain.
  Proof.
    intros valid.
    unfold validate_header in valid.
    repeat
      (match goal with
      | [H: context[Nat.eqb ?a ?b] |- _] => destruct (Nat.eqb_spec a b)
      | [H: context[Nat.ltb ?a ?b] |- _] => destruct (Nat.ltb_spec a b)
      | [H: context[Nat.leb ?a ?b] |- _] => destruct (Nat.leb_spec a b)
      | [H: context[Z.geb ?a ?b] |- _] => destruct (Z.geb_spec a b)
      end; [|repeat rewrite Bool.andb_false_r in valid; cbn in valid; congruence]).
    destruct (address_not_contract (block_creator header)) eqn:to_acc;
      [|cbn in valid; congruence].
    apply Bool.negb_true_iff in to_acc.
    apply build_is_valid_next_block; cbn; auto.
    lia.
  Defined.

  Definition find_origin_neq_from (actions : list Action) : option Action :=
    find (fun act => address_neqb (act_origin act) (act_from act)) actions.

  Lemma validate_origin_neq_from_valid actions :
    find_origin_neq_from actions = None ->
    Forall (fun act => address_eqb (act_origin act) (act_from act) = true) actions.
  Proof.
    intros find_none.
    unfold find_origin_neq_from in find_none.
    specialize (List.find_none _ _ find_none) as all_nin.
    cbn in *.
    assert (all_nin0 : forall x, In x actions -> (act_origin x =? act_from x)%address = true).
    { intros. now apply ssrbool.negbFE. }
    now apply Forall_forall in all_nin0.
  Defined.

  Definition find_invalid_root_action (actions : list Action) : option Action :=
    find (fun act => address_is_contract (act_from act)) actions.

  Lemma validate_actions_valid actions :
    find_invalid_root_action actions = None ->
    Forall (fun act => act_is_from_account act) actions.
  Proof.
    intros find_none.
    unfold find_invalid_root_action in find_none.
    specialize (List.find_none _ _ find_none) as all_nin.
    unfold act_is_from_account.
    now apply Forall_forall in all_nin.
  Defined.

  Definition add_new_block (header : BlockHeader) (lc : LocalChain) : LocalChain :=
    let lc := add_balance (block_creator header) (block_reward header) lc in
    lc<|lc_height := block_height header|>
      <|lc_slot := block_slot header|>
      <|lc_fin_height := block_finalized_height header|>.

  Lemma add_new_block_equiv header (lc : LocalChain) (env : Environment) :
    EnvironmentEquiv lc env ->
    EnvironmentEquiv
      (add_new_block header lc)
      (Blockchain.add_new_block_to_env header env).
  Proof.
    intros eq.
    apply build_env_equiv; try apply eq; auto.
    intros addr.
    cbn.
    unfold Blockchain.add_balance.
    destruct_address_eq.
    - subst. rewrite FMap.find_partial_alter.
      cbn.
      f_equal.
      apply eq.
    - rewrite FMap.find_partial_alter_ne; auto.
      apply eq.
  Defined.

  (* The computational bits of adding a block *)
  Definition add_block_exec
            (depth_first : bool)
            (lc : LocalChain)
            (header : BlockHeader)
            (actions : list Action) : result LocalChain AddBlockError :=
    do (if validate_header header lc then Ok tt else Err (invalid_header header));
    do (match find_origin_neq_from actions with
        | Some act => Err (origin_from_mismatch act)
        | None => Ok tt
        end);
    do (match find_invalid_root_action actions with
        | Some act => Err (invalid_root_action act)
        | None => Ok tt
        end);
    let lc := add_new_block header lc in
    execute_actions 1000 actions lc depth_first.

  Local Hint Resolve validate_header_valid validate_actions_valid validate_origin_neq_from_valid : core.

  (* Adds a block to the chain by executing the specified chain actions.
    Returns the new chain if the execution succeeded (for instance,
    transactions need enough funds, contracts should not reject, etc. *)
  Definition add_block
            (depth_first : bool)
            (lcb : LocalChainBuilder)
            (header : BlockHeader)
            (actions : list Action) : result LocalChainBuilder AddBlockError.
  Proof.
    set (lcopt := add_block_exec depth_first (lcb_lc lcb) header actions).
    unfold add_block_exec in lcopt.
    destruct lcopt as [lc|e] eqn:exec; [|exact (Err e)].
    subst lcopt.
    destruct (validate_header _) eqn:validate; [|cbn in exec; congruence].
    destruct (find_origin_neq_from _) eqn:no_origin_neq_from; [cbn in exec; congruence|].
    destruct (find_invalid_root_action _) eqn:no_invalid_root_act; [cbn in exec; congruence|].
    destruct lcb as [prev_lc_end prev_lcb_trace].
    refine (Ok {| lcb_lc := lc; lcb_trace := _ |}).
    cbn -[execute_actions] in exec.

    refine (execute_actions_trace _ _ _ _ _ _ exec).
    refine (snoc prev_lcb_trace _).
    apply (step_block _ _ header); auto.
    apply add_new_block_equiv.
    reflexivity.
  Defined.

  Definition LocalChainBuilderImpl : ChainBuilderType :=
    {| builder_type := LocalChainBuilder;
      builder_initial := lcb_initial;
      builder_env lcb := lcb_lc lcb;
      builder_add_block := add_block DepthFirst;
      builder_trace := lcb_trace; |}.

End LocalBlockchain.

Arguments LocalChainBase : clear implicits.
Arguments LocalChainBuilder : clear implicits.
Arguments LocalChainBuilderImpl : clear implicits.
Arguments lcb_initial : clear implicits.


(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Constant propagation over RTL.  This is one of the optimizations
  performed at RTL level.  It proceeds by a standard dataflow analysis
  and the corresponding code rewriting. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import Lattice.
Require Import Kildall.
Require Import Liveness.
Require Import ConstpropOp.

(** * Static analysis *)

(** The type [approx] of compile-time approximations of values is
  defined in the machine-dependent part [ConstpropOp]. *)

(** We equip this type of approximations with a semi-lattice structure.
  The ordering is inclusion between the sets of values denoted by
  the approximations. *)

Module Approx <: SEMILATTICE_WITH_TOP.
  Definition t := approx.
  Definition eq (x y: t) := (x = y).
  Definition eq_refl: forall x, eq x x := (@refl_equal t).
  Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t).
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t).
  Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}.
  Proof.
    decide equality.
    apply Int.eq_dec.
    apply Float.eq_dec.
    apply Int64.eq_dec.
    apply Int.eq_dec.
    apply ident_eq.
    apply Int.eq_dec.
  Defined.
  Definition beq (x y: t) := if eq_dec x y then true else false.
  Lemma beq_correct: forall x y, beq x y = true -> x = y.
  Proof.
    unfold beq; intros.  destruct (eq_dec x y). auto. congruence.
  Qed.

  Definition ge (x y: t) : Prop := x = Unknown \/ y = Novalue \/ x = y.

  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge; tauto.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge; intuition congruence.
  Qed.
  Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'.
  Proof.
    unfold eq, ge; intros; congruence.
  Qed.
  Definition bot := Novalue.
  Definition top := Unknown.
  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot; tauto.
  Qed.
  Lemma ge_top: forall x, ge top x.
  Proof.
    unfold ge, bot; tauto.
  Qed.
  Definition lub (x y: t) : t :=
    if eq_dec x y then x else
    match x, y with
    | Novalue, _ => y
    | _, Novalue => x
    | _, _ => Unknown
    end.
  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold lub; intros.
    case (eq_dec x y); intro.
    apply ge_refl. apply eq_refl.
    destruct x; destruct y; unfold ge; tauto.
  Qed.
  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold lub; intros.
    case (eq_dec x y); intro.
    apply ge_refl. subst. apply eq_refl.
    destruct x; destruct y; unfold ge; tauto.
  Qed.
End Approx.

Module D := LPMap Approx.

(** We keep track of read-only global variables (i.e. "const" global
  variables in C) as a map from their names to their initialization
  data. *)

Definition global_approx : Type := PTree.t (list init_data).

(** Given some initialization data and a byte offset, compute a static
  approximation of the result of a memory load from a memory block
  initialized with this data. *)

Fixpoint eval_load_init (chunk: memory_chunk) (pos: Z) (il: list init_data): approx :=
  match il with
  | nil => Unknown
  | Init_int8 n :: il' =>
      if zeq pos 0 then
        match chunk with
        | Mint8unsigned => I (Int.zero_ext 8 n)
        | Mint8signed => I (Int.sign_ext 8 n)
        | _ => Unknown
        end
      else eval_load_init chunk (pos - 1) il'
  | Init_int16 n :: il' =>
      if zeq pos 0 then
        match chunk with
        | Mint16unsigned => I (Int.zero_ext 16 n)
        | Mint16signed => I (Int.sign_ext 16 n)
        | _ => Unknown
        end
      else eval_load_init chunk (pos - 2) il'
  | Init_int32 n :: il' =>
      if zeq pos 0
      then match chunk with Mint32 => I n | _ => Unknown end
      else eval_load_init chunk (pos - 4) il'
  | Init_int64 n :: il' =>
      if zeq pos 0
      then match chunk with Mint64 => L n | _ => Unknown end
      else eval_load_init chunk (pos - 8) il'
  | Init_float32 n :: il' =>
      if zeq pos 0
      then match chunk with
           | Mfloat32 => if propagate_float_constants tt then F (Float.singleoffloat n) else Unknown
           | _ => Unknown
           end
      else eval_load_init chunk (pos - 4) il'
  | Init_float64 n :: il' =>
      if zeq pos 0
      then match chunk with
           | Mfloat64 => if propagate_float_constants tt then F n else Unknown
           | _ => Unknown
           end
      else eval_load_init chunk (pos - 8) il'
  | Init_addrof symb ofs :: il' =>
      if zeq pos 0
      then match chunk with Mint32 => G symb ofs | _ => Unknown end
      else eval_load_init chunk (pos - 4) il'
  | Init_space n :: il' =>
      eval_load_init chunk (pos - Zmax n 0) il'
  end.

(** Compute a static approximation for the result of a load at an address whose
  approximation is known.  If the approximation points to a global variable,
  and this global variable is read-only, we use its initialization data
  to determine a static approximation.  Otherwise, [Unknown] is returned. *)

Definition eval_static_load (gapp: global_approx) (chunk: memory_chunk) (addr: approx) : approx :=
  match addr with
  | G symb ofs =>
      match gapp!symb with
      | None => Unknown
      | Some il => eval_load_init chunk (Int.unsigned ofs) il
      end
  | _ => Unknown
  end.

(** The transfer function for the dataflow analysis is straightforward.
  For [Iop] instructions, we set the approximation of the destination
  register to the result of executing abstractly the operation.
  For [Iload] instructions, we set the approximation of the destination
  register to the result of [eval_static_load].
  For [Icall] and [Ibuiltin], the destination register becomes [Unknown].
  Other instructions keep the approximations unchanged, as they preserve
  the values of all registers. *)

Definition approx_reg (app: D.t) (r: reg) :=
  D.get r app.

Definition approx_regs (app: D.t) (rl: list reg):=
  List.map (approx_reg app) rl.

Definition transfer (gapp: global_approx) (f: function) (pc: node) (before: D.t) :=
  match f.(fn_code)!pc with
  | None => before
  | Some i =>
      match i with
      | Iop op args res s =>
          let a := eval_static_operation op (approx_regs before args) in
          D.set res a before
      | Iload chunk addr args dst s =>
          let a := eval_static_load gapp chunk
                     (eval_static_addressing addr (approx_regs before args)) in
          D.set dst a before
      | Icall sig ros args res s =>
          D.set res Unknown before
      | Ibuiltin ef args res s =>
          D.set res Unknown before
      | _ =>
          before
      end
  end.

(** To reduce the size of approximations, we preventively set to [Top]
  the approximations of registers used for the last time in the
  current instruction. *)

Definition transfer' (gapp: global_approx) (f: function) (lastuses: PTree.t (list reg))
                     (pc: node) (before: D.t) :=
  let after := transfer gapp f pc before in
  match lastuses!pc with
  | None => after
  | Some regs => List.fold_left (fun a r => D.set r Unknown a) regs after
  end.

(** The static analysis itself is then an instantiation of Kildall's
  generic solver for forward dataflow inequations. [analyze f]
  returns a mapping from program points to mappings of pseudo-registers
  to approximations.  It can fail to reach a fixpoint in a reasonable
  number of iterations, in which case we use the trivial mapping
  (program point -> [D.top]) instead. *)

Module DS := Dataflow_Solver(D)(NodeSetForward).

Definition analyze (gapp: global_approx) (f: RTL.function): PMap.t D.t :=
  let lu := Liveness.last_uses f in
  match DS.fixpoint (successors f) (transfer' gapp f lu)
                    ((f.(fn_entrypoint), D.top) :: nil) with
  | None => PMap.init D.top
  | Some res => res
  end.

(** * Code transformation *)

(** The code transformation proceeds instruction by instruction.
    Operators whose arguments are all statically known are turned
    into ``load integer constant'', ``load float constant'' or
    ``load symbol address'' operations.  Likewise for loads whose
    result can be statically predicted.  Operators for which some
    but not all arguments are known are subject to strength reduction,
    and similarly for the addressing modes of load and store instructions.
    Conditional branches and multi-way branches are statically resolved
    into [Inop] instructions if possible. Other instructions are unchanged.

    In addition, we try to jump over conditionals whose condition can
    be statically resolved based on the abstract state "after" the
    instruction that branches to the conditional.  A typical example is:
<<
          1: x := 0 and goto 2
          2: if (x == 0) goto 3 else goto 4
>>
    where other instructions branch into 2 with different abstract values
    for [x].  We transform this code into:
<<
          1: x := 0 and goto 3
          2: if (x == 0) goto 3 else goto 4
>>
*)

Definition transf_ros (app: D.t) (ros: reg + ident) : reg + ident :=
  match ros with
  | inl r =>
      match D.get r app with
      | G symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros
      | _ => ros
      end
  | inr s => ros
  end.

Parameter generate_float_constants : unit -> bool.

Definition const_for_result (a: approx) : option operation :=
  match a with
  | I n => Some(Ointconst n)
  | F n => if generate_float_constants tt then Some(Ofloatconst n) else None
  | G symb ofs => Some(Oaddrsymbol symb ofs)
  | S ofs => Some(Oaddrstack ofs)
  | _ => None
  end.

Fixpoint successor_rec (n: nat) (f: function) (app: D.t) (pc: node) : node :=
  match n with
  | O => pc
  | Datatypes.S n' =>
      match f.(fn_code)!pc with
      | Some (Inop s) =>
          successor_rec n' f app s
      | Some (Icond cond args s1 s2) =>
          match eval_static_condition cond (approx_regs app args) with
          | Some b => if b then s1 else s2
          | None => pc
          end
      | _ => pc
      end
  end.

Definition num_iter := 10%nat.

Definition successor (f: function) (app: D.t) (pc: node) : node :=
  successor_rec num_iter f app pc.

Function annot_strength_reduction
     (app: D.t) (targs: list annot_arg) (args: list reg) :=
  match targs, args with
  | AA_arg ty :: targs', arg :: args' =>
      let (targs'', args'') := annot_strength_reduction app targs' args' in
      match ty, approx_reg app arg with
      | Tint, I n => (AA_int n :: targs'', args'')
      | Tfloat, F n => (AA_float n :: targs'', args'')
      | _, _ => (AA_arg ty :: targs'', arg :: args'')
      end
  | targ :: targs', _ =>
      let (targs'', args'') := annot_strength_reduction app targs' args in
      (targ :: targs'', args'')
  | _, _ =>
      (targs, args)
  end.

Function builtin_strength_reduction
      (app: D.t) (ef: external_function) (args: list reg) :=
  match ef, args with
  | EF_vload chunk, r1 :: nil =>
      match approx_reg app r1 with
      | G symb n1 => (EF_vload_global chunk symb n1, nil)
      | _ => (ef, args)
      end
  | EF_vstore chunk, r1 :: r2 :: nil =>
      match approx_reg app r1 with
      | G symb n1 => (EF_vstore_global chunk symb n1, r2 :: nil)
      | _ => (ef, args)
      end
  | EF_annot text targs, args =>
      let (targs', args') := annot_strength_reduction app targs args in
      (EF_annot text targs', args')
  | _, _ =>
      (ef, args)
  end.

Definition transf_instr (gapp: global_approx) (f: function) (apps: PMap.t D.t)
                       (pc: node) (instr: instruction) :=
  let app := apps!!pc in
  match instr with
  | Iop op args res s =>
      let a := eval_static_operation op (approx_regs app args) in
      let s' := successor f (D.set res a app) s in
      match const_for_result a with
      | Some cop =>
          Iop cop nil res s'
      | None =>
          let (op', args') := op_strength_reduction op args (approx_regs app args) in
          Iop op' args' res s'
      end
  | Iload chunk addr args dst s =>
      let a := eval_static_load gapp chunk
                  (eval_static_addressing addr (approx_regs app args)) in
      match const_for_result a with
      | Some cop =>
          Iop cop nil dst s
      | None =>
          let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in
          Iload chunk addr' args' dst s
      end
  | Istore chunk addr args src s =>
      let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in
      Istore chunk addr' args' src s
  | Icall sig ros args res s =>
      Icall sig (transf_ros app ros) args res s
  | Itailcall sig ros args =>
      Itailcall sig (transf_ros app ros) args
  | Ibuiltin ef args res s =>
      let (ef', args') := builtin_strength_reduction app ef args in
      Ibuiltin ef' args' res s
  | Icond cond args s1 s2 =>
      match eval_static_condition cond (approx_regs app args) with
      | Some b =>
          if b then Inop s1 else Inop s2
      | None =>
          let (cond', args') := cond_strength_reduction cond args (approx_regs app args) in
          Icond cond' args' s1 s2
      end
  | Ijumptable arg tbl =>
      match approx_reg app arg with
      | I n =>
          match list_nth_z tbl (Int.unsigned n) with
          | Some s => Inop s
          | None => instr
          end
      | _ => instr
      end
  | _ =>
      instr
  end.

Definition transf_code (gapp: global_approx) (f: function) (app: PMap.t D.t) (instrs: code) : code :=
  PTree.map (transf_instr gapp f app) instrs.

Definition transf_function (gapp: global_approx) (f: function) : function :=
  let approxs := analyze gapp f in
  mkfunction
    f.(fn_sig)
    f.(fn_params)
    f.(fn_stacksize)
    (transf_code gapp f approxs f.(fn_code))
    f.(fn_entrypoint).

Definition transf_fundef (gapp: global_approx) (fd: fundef) : fundef :=
  AST.transf_fundef (transf_function gapp) fd.

Fixpoint make_global_approx (gapp: global_approx) (gdl: list (ident * globdef fundef unit)): global_approx :=
  match gdl with
  | nil => gapp
  | (id, gl) :: gdl' =>
      let gapp1 :=
        match gl with
        | Gfun f => PTree.remove id gapp
        | Gvar gv =>
            if gv.(gvar_readonly) && negb gv.(gvar_volatile)
            then PTree.set id gv.(gvar_init) gapp
            else PTree.remove id gapp
        end in
      make_global_approx gapp1 gdl'
  end.

Definition transf_program (p: program) : program :=
  let gapp := make_global_approx (PTree.empty _) p.(prog_defs) in
  transform_program (transf_fundef gapp) p.