(* Correctness of the Assume Insertion pass *)
(* A pass of the middle-end optimizer *)
(* Inserts an Assume insertion just after an Anchor *)

Require Import internal_simulations.
Require Import sem_properties.
Require Import assume_insertion.
Require Import Coq.MSets.MSetPositive.
Require Import def_regs.
Require Import common.
Require Import IR.
Require Import IRinterpreter.
Require Import Errors.
Require Import monad.
Require Import monad_impl.
Require Import mixed_sem.
Require Import sem_properties.
Require Import customSmallstep.

Require Import IRtoRTLblock_proof.
(* so we can resue the addstk typing of the monads *)
(* TODO: We could get that in another file *)

(** * Matching the stack and properties  *)
(* Matching stackframes: a version may have been replaced with its optimized version *)
Inductive match_stackframe (v:version) (fid:fun_id) (guard:expr) (ancl:label) (params:list reg): stackframe -> stackframe -> Prop :=
| frame_same:
    forall sf, (match_stackframe v fid guard ancl params) sf sf
| frame_opt:
    forall r lbl rm vins abs
      (AS_INSERT: insert_assume_version v fid guard ancl params = OK vins)
      (DEFREGS: defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs)
      (DEF: forall retval, defined (rm#r<-retval) (def_absstate_get lbl abs)),
      (match_stackframe v fid guard ancl params) (IR_SF (r, v, lbl, rm)) (IR_SF (r, vins, lbl, rm)).

(* Generalizing match_stackframe to the entire stack *)
Inductive match_stack (v:version) (fid:fun_id) (guard:expr) (ancl:label) (params:list reg): stack -> stack -> Prop :=
| match_nil:
    (match_stack v fid guard ancl params) nil nil
| match_cons:
    forall s s' sf sf'
      (MS: (match_stack v fid guard ancl params) s s')
      (MSF: (match_stackframe v fid guard ancl params) sf sf'),
      (match_stack v fid guard ancl params) (sf::s) (sf'::s').

Lemma match_stack_same:
  forall s v fid guard ancl params,
    (match_stack v fid guard ancl params) s s.
Proof.
  intros s v fid guard ancl. induction s; constructor. auto. constructor.
Qed.

Lemma match_app:
  forall synth s s' v fid guard ancl params,
    (match_stack v fid guard ancl params) s s' ->
    (match_stack v fid guard ancl params) (synth++s) (synth++s').
Proof.
  intros. induction synth.
  - simpl. auto.
  - repeat rewrite <- app_comm_cons. apply match_cons. auto. constructor.
Qed.

Lemma app_match:
  forall synth synthopt s s' v fid guard ancl params,
    (match_stack v fid guard ancl params) s s' ->
    (match_stack v fid guard ancl params) synth synthopt ->
    (match_stack v fid guard ancl params) (synth++s) (synthopt++s').
Proof.
  intros. induction H0.
  - simpl. auto.
  - repeat rewrite <- app_comm_cons. apply match_cons; auto.
Qed.

(** * Index and order used in the simulation *)
(* There is one stuttering step for each inserted Anchor *)
Inductive as_index: Type :=
| One : as_index
| Zero: as_index.

Inductive as_order: as_index -> as_index -> Type :=
| order: as_order Zero One.

Lemma wfounded: well_founded as_order.
Proof.
  unfold well_founded. intros a. constructor. intros y H. inv H. constructor. intros y H. inv H.
Qed.

Lemma trans: Relation_Definitions.transitive _ as_order.
Proof.
  unfold Relation_Definitions.transitive. intros x y z H H0. inv H. inv H0.
Qed.

(** * The match_states relation  *)
(* This proof is a backward internal simulation.
   At the Anchor instruction, we take a stuttering step if the Assume succeeds
   If it fails, we take a single step to the target version.

<<

       st1 --------------- st2
        |                   |
       t|(1 or 2 steps)     |t
        |                   |
        v                   v
       st1'--------------- st2'

>>
*)

Inductive match_states (p:program) (v:version) (fid:fun_id) (guard: expr) (ancl:label) (params:list reg): as_index -> mixed_state -> mixed_state -> Prop :=

| assume_match:                     (* matching at the assume instruction *)
    forall vins stk stk' top heap rm fresh fa la vm next (* newver *) newrm abs
      (MATCHSTACK: (match_stack v fid guard ancl params) stk stk')
      (OPT: insert_assume_version v fid guard ancl params = OK vins)
      (DEFREGS: defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs)
      (DEF: defined rm (def_absstate_get ancl abs))
      (VALIDATE: validator v ancl guard params = OK tt)
      (FS_OPT: (ver_code vins) # ancl = Some (Anchor (fa,la) vm fresh))
      (AS_OPT: (ver_code vins) # fresh = Some (Assume guard (fa,la) vm next))
      (FS_SRC: (ver_code v) # ancl = Some (Anchor (fa,la) vm next))
      (* (FINDF: find_base_version fa p = Some newver) *)
      (UPDATE: update_regmap vm rm = OK newrm),
      (match_states p v fid guard ancl params) Zero
        (Halt_IR (v, ancl, rm), mkmut stk top heap)
        (Halt_IR (vins, fresh, rm), mkmut stk' top heap)

| opt_match:           (* matching inside the optimized version *)
    forall vins stk stk' top heap lbl rm abs
      (MATCHSTACK: (match_stack v fid guard ancl params) stk stk')
      (OPT: insert_assume_version v fid guard ancl params = OK vins)
      (DEFREGS: defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs)
      (DEF: defined rm (def_absstate_get lbl abs)),
      (match_states p v fid guard ancl params) One
        (Halt_IR (v, lbl, rm), mkmut stk top heap)
        (Halt_IR (vins, lbl, rm), mkmut stk' top heap)

| refl_match:                   (* matching outside of the optimized version *)
    forall synchro stk stk' top heap
      (MATCHSTACK: (match_stack v fid guard ancl params) stk stk'),
      (match_states p v fid guard ancl params) Zero (synchro, mkmut stk top heap) (synchro, mkmut stk' top heap).

(* | final_match:                  (* matching final states -> should be taken care of by refl*) *)
(*     forall retval ms, *)
(*       (match_states p v fid guard ancl params) One (Final retval ms) (Final retval ms). *)

(** * Code preservation properties  *)
Lemma code_preservation':
  forall vsrc vins fid guard ancl lbl params,
    insert_assume_version vsrc fid guard ancl params = OK vins ->
    lbl <> ancl ->
    forall iopt isrc,
      (ver_code vins) # lbl = Some iopt ->
      (ver_code vsrc) # lbl = Some isrc ->
      iopt = isrc.
Proof.
  intros vsrc vins fid guard ancl lbl params OPT NOTFS iopt isrc CODEOPT CODESRC.
  unfold insert_assume_version in OPT. repeat do_ok.
  destruct (c!ancl) eqn:CODEFS; inv H1. destruct i; inv H0. repeat do_ok. destruct u.
  simpl in CODEOPT. inv HDO.
  poseq_destr (fresh_sug (Pos.succ ancl) (ver_code vsrc)) lbl.
  - erewrite fresh_sug_correct in CODESRC; auto. inv CODESRC.
  - rewrite PTree.gso in CODEOPT; auto. rewrite PTree.gso in CODEOPT; auto.
    rewrite CODESRC in CODEOPT. inv CODEOPT. auto.
Qed.

Lemma safe_step_ir:
  forall p rtl nc anc ms v pc rm,
    safe (mixed_sem p rtl nc anc) (Halt_IR (v, pc, rm), ms) ->
    exists t s', (mixed_step anc p rtl nc) (Halt_IR (v, pc, rm), ms) t s'.
Proof.
  intros p rtl nc anc ms v pc rm H. specialize (H (Halt_IR (v,pc,rm), ms) (star_refl _ _ _)).
  destruct H as [[r FINAL]|[t [s'' STEP]]]; eauto. inv FINAL.
Qed.

Lemma safe_step:
  forall p rtl nc anc synchro ms,
    safe (mixed_sem p rtl nc anc) (synchro, ms) ->
    (exists t s', (mixed_step anc p rtl nc) (synchro, ms) t s') \/ (exists r, synchro = EOE r).
Proof.
  intros p rtl nc anc synchro ms H.
  specialize (H (synchro, ms) (star_refl _ _ _)). destruct H as [[r FINAL]|[t [s'' STEP]]]; eauto. inv FINAL.
  right. eauto.
Qed.

Lemma step_code_ir:
  forall p rtl nc anc v pc rm ms news t,
    Step (mixed_sem p rtl nc anc) (Halt_IR (v, pc, rm), ms) t news ->
    exists i, (ver_code v) ! pc = Some i.
Proof.
  intros. inv H; eauto.
  unfold ir_step in STEP. repeat sdo_ok. unfold ir_int_step in HDO. repeat sdo_ok. eauto.
Qed.

Lemma safe_code:
  forall p rtl nc anc s v pc rm ms top,
    safe (mixed_sem p rtl nc anc) (Halt_IR (v, pc, rm), mkmut s top ms) ->
    exists i, (ver_code v) ! pc = Some i.
Proof.
  intros. apply safe_step_ir in H as [s' [t STEP]].
  eapply step_code_ir; simpl; eauto.
Qed.

Lemma code_preservation:        (* use at opt_match *)
  forall p p' rtl nc s s' rm top ms t news vsrc vins fid guard ancl lbl params,
    insert_assume_version vsrc fid guard ancl params = OK vins ->
    lbl <> ancl ->
    safe (mixed_sem p rtl nc AnchorOn) (Halt_IR (vsrc, lbl, rm), mkmut s top ms) ->
    Step (mixed_sem p' rtl nc AnchorOn) (Halt_IR (vins, lbl, rm), mkmut s' top ms) t news ->
    (ver_code vsrc) # lbl = (ver_code vins) # lbl.
Proof.
  intros p p' rtl nc s s' rm top ms t news vsrc vins fid guard ancl lbl params H H0 H1 H2.
  apply safe_code in H1 as [isrc CODESRC]. apply step_code_ir in H2 as [iopt CODEOPT].
  rewrite CODESRC. rewrite CODEOPT. f_equal. symmetry. eapply code_preservation'; eauto.
Qed.

(* The anchor instruction has been changed to point to the Assume *)
Lemma anchor_changed:
  forall vsrc fid guard vins ancl params,
    insert_assume_version vsrc fid guard ancl params = OK vins ->
    exists tgt vm fresh next,
      (ver_code vins) # ancl = Some (Anchor tgt vm fresh) /\
      (ver_code vsrc) # ancl = Some (Anchor tgt vm next) /\
      (ver_code vins) # fresh = Some (Assume guard tgt vm next).
Proof.
  intros vsrc fid guard vins ancl params OPT. unfold insert_assume_version in OPT. repeat do_ok.
  inv HDO. destruct ((ver_code vsrc)!ancl) eqn:FS_SRC; inv H1.
  destruct i eqn:ANCHOR; inv H0. repeat do_ok. exists d. exists v.
  exists (fresh_sug (Pos.succ ancl) (ver_code vsrc)). exists l. simpl.
  split; auto; try split; auto.
  - poseq_destr (fresh_sug (Pos.succ ancl) (ver_code vsrc)) ancl.
    + erewrite fresh_sug_correct in FS_SRC; eauto. inv FS_SRC.
    + rewrite PTree.gso; auto. rewrite PTree.gss. auto.
  - rewrite PTree.gss. auto.
Qed.

Lemma preservation_code:
  forall vsrc vins fid guard ancl lbl params i,
    insert_assume_version vsrc fid guard ancl params = OK vins ->
    lbl <> ancl ->
    (ver_code vsrc) # lbl = Some i ->
    (ver_code vins) # lbl = Some i.
Proof.
  intros vsrc vins fid guard ancl lbl params i H H0 H1. unfold insert_assume_version in H. repeat do_ok.
  destruct (c!ancl) eqn:CODEFS. 2: inv H2. destruct i0; inv H2. repeat do_ok. simpl. inv HDO.
  rewrite PTree.gso. rewrite PTree.gso; auto. poseq_destr lbl (fresh_sug (Pos.succ ancl) (ver_code vsrc)); auto.
  erewrite fresh_sug_correct in H1; auto. inv H1.
Qed.

(** * Progress Preservation  *)
Lemma evaluate_reg:
  forall rm rs r,
    defined rm (DefFlatRegset.Inj rs) ->
    check_reg r rs = true ->
    exists v, eval_reg r rm = OK v.
Proof.
  intros rm rs r H H0.
  unfold check_reg in H0. rewrite PositiveSet.mem_spec in H0.
  unfold defined in H. apply H in H0. destruct H0. exists x. unfold eval_reg. rewrite H0. auto.
Qed.

Lemma evaluate_expr:
  forall rm rs e,
    defined rm (DefFlatRegset.Inj rs) ->
    check_expr e rs = true ->
    exists v, eval_expr e rm = OK v.
Proof.
  intros rm rs e H H0. destruct e; simpl in H0.
  - assert (H': exists v, eval_reg r rm = OK v /\ exists v0, eval_reg r0 rm = OK v0).
    { destruct b; try solve[inv H0]; apply andb_prop in H0; destruct H0; eauto;
        eapply evaluate_reg in H0; eapply evaluate_reg in H1; eauto; destruct H0; destruct H1; eauto. }
    destruct H' as [v [EV [v' EV']]]. destruct b; simpl; rewrite EV; rewrite EV'; simpl; eauto.
    inv H0.
  - eapply evaluate_reg in H0; eauto. destruct H0. destruct u; simpl; rewrite H0; simpl; eauto.
  - destruct z; simpl; eauto.
Qed.

Lemma base_version_set_version:
  forall vins f,
    fn_base (set_version_function vins f) = fn_base f.
Proof.
  intros vins f. unfold set_version_function. simpl. auto.
Qed.

Lemma current_version_set_version:
  forall vins f,
    current_version (set_version_function vins f) = vins.
Proof.
  intros vins f. unfold set_version_function, current_version. simpl. auto.
Qed.

(* Evaluating a guard if it uses defined registers should be defined *)
(* Lemma evaluate_succeeds: *)
(*   forall rm guard rs, *)
(*     defined rm (DefFlatRegset.Inj rs) -> *)
(*     check_guard guard rs = true -> *)
(*     exists v, eval_list_expr guard rm v. *)
(* Proof. *)
(*   intros rm guard rs H H0. induction guard; intros. *)
(*   - exists true. constructor. *)
(*   - simpl in H0. apply andb_prop in H0. destruct H0. eapply evaluate_expr in H0; eauto. *)
(*     destruct H0. destruct x. apply IHguard in H1. destruct H1. destruct z. *)
(*     + esplit. eapply eval_cons_false; eauto. *)
(*     + esplit. eapply eval_cons_true; eauto. unfold Zne. unfold not. intro. inv H1; inv H2. *)
(*     + esplit. eapply eval_cons_true; eauto. unfold Zne. unfold not. intro. inv H1; inv H2. *)
(* Qed. *)
(* DEPRECATED until we use lists *)

Ltac def_ok :=
  match goal with
  | [CODE: (ver_code ?vsrc) ! ?lbl = Some ?i |- _] =>
    eapply def_analyze_correct; eauto; simpl; auto; unfold def_dr_transf; try rewrite CODE; auto
  end.

Lemma progress_preserved:
  forall f vsrc vins fid guard ancl params s1 s2 p nc i,
    insert_assume_version vsrc fid guard ancl params = OK vins ->
    find_function_ir fid p = Some f ->
    vsrc = current_version f ->
    match_states p vsrc fid guard ancl params i s1 s2 ->
    safe (mixed_sem p None nc AnchorOn) s1 ->
    (exists r : Integers.Int.int, final_mixed_state (set_version p fid vins) s2 r) \/
    (exists (t : trace) (s2' : mixed_state),
        Step (mixed_sem (set_version p fid vins) None nc AnchorOn) s2 t s2').
Proof.
  intros f vsrc vins fid guard ancl params s1 s2 p nc i OPTV FINDOPT CURVER MATCH SAFE.
  inv MATCH.
  - unfold validator in VALIDATE. rewrite FS_SRC in VALIDATE. repeat do_ok.
    destruct (def_absstate_get ancl d) eqn:ABSDR; inv H0.
    destruct (check_expr guard r) eqn:CHECK; inv H1.
    inv DEFREGS. rewrite ABSDR in DEF. eapply evaluate_expr in CHECK as [v EVAL]; eauto.
    right. exists E0. rewrite OPT in OPTV. inv OPTV. destruct (bool_of_int v) eqn:BOOL.
    + econstructor. apply IR_step. unfold ir_step. rewrite exec_bind2. unfold sbind2, sbind.
      unfold ir_int_step. rewrite AS_OPT. simpl. rewrite exec_bind. unfold sbind, fret'.
      rewrite EVAL. simpl. rewrite BOOL. simpl. eauto.
    + econstructor. apply IR_step. unfold ir_step. rewrite exec_bind2. unfold sbind2, sbind.
      unfold ir_int_step. rewrite AS_OPT. simpl. rewrite exec_bind. unfold sbind, fret'.
      rewrite EVAL. simpl. rewrite BOOL. rewrite UPDATE. simpl. eauto.

  - poseq_destr lbl ancl.
    + rewrite OPT in OPTV. inv OPTV. unfold insert_assume_version in OPT. repeat do_ok.
      destruct (c!ancl) eqn:CODEFS; inv H1. destruct i; inv H0.
      right. exists E0. exists (Halt_IR (vins, (fresh_sug (Pos.succ ancl) c), rm), mkmut stk' top heap).
      repeat do_ok. simpl. destruct d as [ftgt ltgt].
      apply safe_step_ir in SAFE as STEP. destruct STEP as [t [s'' STEP]].
      inv HDO. inv STEP.
      * exfalso. eapply ir_noanchor in STEP0; eauto.
      * rewrite ANCHOR in CODEFS. inv CODEFS. eapply Anchor_go_on; eauto. simpl. rewrite PTree.gso.
        rewrite PTree.gss. eauto. unfold not; intros H.
        symmetry in H. apply fresh_sug_correct in H. rewrite H in ANCHOR. inv ANCHOR.
      * rewrite ANCHOR in CODEFS. inv CODEFS. eapply Anchor_go_on; eauto. simpl. rewrite PTree.gso.
        rewrite PTree.gss. eauto. unfold not; intros H.
        symmetry in H. apply fresh_sug_correct in H. rewrite H in ANCHOR. inv ANCHOR.

    + apply safe_step_ir in SAFE as STEP. destruct STEP as [t [s'' STEP]].
      right. rewrite OPT in OPTV. inv OPTV.
      apply safe_code in SAFE. destruct SAFE as [i CODESRC].
      eapply preservation_code in HEQ as SAME_CODE; eauto.
      inv STEP.
      * exists t. unfold ir_step in STEP0. repeat sdo_ok. unfold ir_int_step in HDO.
        rewrite CODESRC in HDO. repeat sdo_ok. inv HDO1.
        { destruct i0; repeat sdo_ok.
          - econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl. eauto.
          - econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
            unfold fret'. rewrite HDO. simpl. eauto.
          - poseq_destr f0 fid.
            + simpl in HDO. repeat sdo_ok.
              unfold n_push_interpreter_stackframe in HDO0. simpl in HDO0. destruct top; inv HDO0.
              econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
              unfold sbind. unfold n_push_interpreter_stackframe. simpl. rewrite HDO. simpl. eauto.
            + simpl in HDO. repeat sdo_ok.
              unfold n_push_interpreter_stackframe in HDO0. simpl in HDO0. destruct top; inv HDO0.
              econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
              unfold sbind. unfold n_push_interpreter_stackframe. simpl. rewrite HDO. simpl. eauto.
          - destruct (bool_of_int i) eqn:BOOL; repeat sdo_ok.
            + econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
              rewrite HDO1. simpl. rewrite BOOL. simpl. eauto.
            + econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
              rewrite HDO1. simpl. rewrite BOOL. simpl. eauto.
          - econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
            rewrite HDO. simpl. eauto.
          - econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
            rewrite HDO. simpl. eauto.
          - econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
            rewrite HDO1. simpl. rewrite HDO. simpl. unfold sbind. unfold n_memset in HDO2.
            unfold n_memset. destruct (Integers.Int.lt i mem_size). inv HDO2. eauto. inv HDO2.
          - econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
            rewrite HDO. simpl. unfold sbind. unfold n_memget in HDO1.
            unfold n_memget. destruct (Integers.Int.lt i mem_size). inv HDO1. 2: inv HDO1.
            simpl. destruct (heap ! (intpos.pos_of_int i)); inv H0. eauto.
          - destruct d. repeat sdo_ok. destruct (bool_of_int i) eqn:BOOL; repeat sdo_ok.
            + econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
              rewrite HDO1. simpl. rewrite BOOL. simpl. eauto.
            + econstructor. eapply IR_step. unfold ir_step, ir_int_step. rewrite SAME_CODE. simpl.
              rewrite HDO1. simpl. rewrite BOOL. simpl. rewrite HDO. simpl. eauto.
          - destruct d. repeat sdo_ok. inv HDO. }

      * exists E0. rewrite CODESRC in ANCHOR. inv ANCHOR.
        exists (Halt_IR (vins, next, rm), mkmut stk' top heap). eapply Anchor_go_on; eauto.
      * exists E0. rewrite CODESRC in ANCHOR. inv ANCHOR.
        exists (Halt_IR (vins, next, rm), mkmut stk' top heap). eapply Anchor_go_on; eauto.

  - apply safe_step in SAFE. destruct SAFE as [[t [s'' STEP]]| [r FINAL]].
    2: { inv FINAL. left. exists r. constructor. }
    right. inv STEP.
    + destruct ms1. eapply addstk_same in STEP0 as [s [APP SAME]]; eauto.
      2: apply addstk_irstep.
      exists t. econstructor. eapply IR_step. simpl. eauto.
    + destruct ms1. eapply addstk_same in STEP0 as [s [APP SAME]]; eauto.
      2: apply addstk_asmstep.
      exists t. econstructor. eapply x86_step. simpl. eauto.
    + econstructor. econstructor. eapply rtl_step; eauto.
    + destruct ms2, ms3. eapply addstk_same in CALLEE as [s [APP SAME]]; eauto.
      2: apply addstk_callee.
      eapply addstk_prim_same in NOT_COMPILED as [stk2 [APP2 SAME2]]; try constructor.
      apply app_same in APP2. subst.
      eapply addstk_same in ARGS as [s3 [APP3 SAME3]]; eauto.
      2: apply addstk_get_args.
      poseq_destr fid fid0.
      * econstructor. econstructor.
        eapply Call_IR with (func:=set_version_function vins func) (ver:=vins); eauto.
        unfold set_version, set_version_funlist. simpl. rewrite GETF. rewrite PTree.gss. auto.
      * econstructor. econstructor.
        eapply Call_IR; eauto. unfold set_version, set_version_funlist. simpl.
        unfold find_function_ir in FINDOPT. rewrite FINDOPT. rewrite PTree.gso; auto.
    + destruct ms2, ms3, ms4. eapply addstk_same in CALLEE as [s [APP SAME]]; eauto.
      2: apply addstk_callee.
      eapply addstk_prim_same in COMPILED as [stk2 [APP2 SAME2]]; try constructor.
      apply app_same in APP2. subst.
      eapply addstk_same in ARGS as [stk3 [APP3 SAME3]]. 2: apply addstk_set_args. subst.
      eapply addstk_prim_same in LOAD as [stk4 [APP4 SAME4]]; try constructor. subst.
      exists E0. econstructor. eapply Call_x86; eauto.
    + inv RTL.
    + inv RTL_BLOCK.
    + destruct ms1. unfold jit.get_retval in RETVAL. destruct loc eqn:LOC.
      * destruct top eqn:TOP; inv RETVAL.
        simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
        destruct state_stacktop; inv OPEN_SF.
        inv MATCHSTACK; inv H0. destruct sf; inv H1.
        2: { destruct a, p, p0, p. inv H0. }
        inv MSF.
        ** econstructor. econstructor. eapply Return_IR; eauto.
           simpl. unfold sbind. simpl. eauto.
           simpl. unfold n_open_stackframe. simpl. eauto.
        ** econstructor. econstructor. eapply Return_IR; eauto.
           simpl. unfold sbind. simpl. eauto.
           simpl. unfold n_open_stackframe. simpl. eauto.
      * inv RETVAL.
        simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
        destruct state_stacktop; inv OPEN_SF.
        inv MATCHSTACK; inv H0. destruct sf; inv H1.
        2: { destruct a, p, p0, p. inv H0. }
        inv MSF.
        ** econstructor. econstructor. eapply Return_IR; eauto.
           simpl. unfold sbind. simpl. eauto.
           simpl. unfold n_open_stackframe. simpl. eauto.
        ** econstructor. econstructor. eapply Return_IR; eauto.
           simpl. unfold sbind. simpl. eauto.
           simpl. unfold n_open_stackframe. simpl. eauto.
    + destruct loc.
      * simpl in RETVAL.  repeat sdo_ok.  unfold n_load in HDO. simpl in HDO.
        destruct top; inv HDO.
        simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
        destruct top; inv OPEN_SF. destruct stk; inv H0. destruct s; inv H1.
        destruct a, p, p0, p. inv H0. inv MATCHSTACK. inv MSF.
        simpl in SET_RETVAL. unfold n_save in SET_RETVAL. inv SET_RETVAL.
        simpl in LOAD_CONT. repeat sdo_ok. unfold n_load_prog_code in HDO. simpl in HDO.
        destruct (nc ! (intpos.pos_of_int caller_fid)) eqn:LOADC; inv HDO.
        destruct a. simpl in LOAD_CONT.
        destruct (t ! (intpos.pos_of_int cont_lbl)) eqn:LOAD; inv LOAD_CONT.
        econstructor. econstructor. eapply Return_x86.
        ** simpl. unfold sbind. unfold n_load. simpl. eauto.
        ** simpl. unfold n_open_stackframe. simpl. eauto.
        ** simpl. unfold n_save. simpl. eauto.
        ** simpl. unfold sbind. unfold n_load_prog_code. simpl. rewrite LOADC. simpl. rewrite LOAD. eauto.
        ** eauto.
      * inv RETVAL. simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
        destruct top; inv OPEN_SF. destruct stk; inv H0. destruct s; inv H1.
        destruct a, p, p0, p. inv H0. inv MATCHSTACK. inv MSF.
        simpl in SET_RETVAL. unfold n_save in SET_RETVAL. inv SET_RETVAL.
        simpl in LOAD_CONT. repeat sdo_ok. unfold n_load_prog_code in HDO. simpl in HDO.
        destruct (nc ! (intpos.pos_of_int caller_fid)) eqn:LOADC; inv HDO.
        destruct a. simpl in LOAD_CONT.
        destruct (t ! (intpos.pos_of_int cont_lbl)) eqn:LOAD; inv LOAD_CONT.
        econstructor. econstructor. eapply Return_x86.
        ** simpl. auto.
        ** simpl. unfold n_open_stackframe. simpl. eauto.
        ** simpl. unfold n_save. simpl. eauto.
        ** simpl. unfold sbind. unfold n_load_prog_code. simpl. rewrite LOADC. simpl. rewrite LOAD. eauto.
        ** eauto.
    + inv RTL.
    + inv RTL_BLOCK.
    + destruct loc.
      * destruct top; inv RETVAL. inv OPEN_SF. unfold n_open_stackframe in H0. simpl in H0.
        destruct top; inv H0. destruct stk; inv H1.
        2: { destruct s; inv H0. destruct a, p, p0, p; inv H1. }
        inv MATCHSTACK. econstructor. econstructor. eapply Return_EOE; eauto.
        simpl. unfold sbind. simpl. eauto.
        simpl. unfold n_open_stackframe. simpl. eauto.
      * inv RETVAL. inv OPEN_SF. unfold n_open_stackframe in H0. simpl in H0.
        destruct top; inv H0. destruct stk; inv H1.
        2: { destruct s; inv H0. destruct a, p, p0, p; inv H1. }
        inv MATCHSTACK. econstructor. econstructor. eapply Return_EOE; eauto.
        simpl. unfold sbind. simpl. eauto.
        simpl. unfold n_open_stackframe. simpl. eauto.
    + destruct ms1, ms2. eapply addstk_same in TARGET as [s [APP SAME]].
      2: apply addstk_target.
      eapply addstk_same in BUILD_RM as [s2 [APP2 SAME2]].
      2: apply addstk_build.
      poseq_destr fid ftgt.
      * econstructor. econstructor. eapply Deopt; eauto.
        unfold set_version, set_version_funlist. simpl. unfold find_function_ir in FINDOPT. rewrite FINDOPT.
        rewrite PTree.gss; auto.
      * econstructor. econstructor. eapply Deopt; eauto.
        unfold set_version, set_version_funlist. simpl. unfold find_function_ir in FINDOPT. rewrite FINDOPT.
        rewrite PTree.gso; eauto.
    + destruct ms1. eapply addstk_same in PRIM_CALL as [s [APP SAME]].
      2: { unfold ASMinterpreter.prim_sem_dec. repeat addstk_auto. }
      econstructor. econstructor. eapply RTL_prim; eauto.
    + econstructor. econstructor. eapply RTL_end; eauto.
    + econstructor. econstructor. eapply RTL_block_end; eauto.
    + econstructor. econstructor. eapply Anchor_go_on; eauto.
    + econstructor. econstructor. eapply Anchor_deopt; eauto.
Qed.

(** * The Internal Backward Simulation  *)
Theorem assume_insertion_correct:
  forall p nc fid guard fs_lbl newp,
    insert_assume fid guard fs_lbl p = OK newp ->
    backward_internal_simulation p newp None None nc nc AnchorOn AnchorOn.
Proof.
  intros p nc fid guard fs_lbl newp OPT. unfold insert_assume in OPT. repeat do_ok.
  rename HDO1 into FINDOPTF. rename v into vins. set (vsrc:=current_version f).
  assert (OPTV: insert_assume_version vsrc fid guard fs_lbl (fn_params f) = OK vins) by auto.
  unfold insert_assume_version in HDO0. repeat do_ok. inv HDO. destruct u.
  set (c:=ver_code vsrc).  rename HDO0 into VALIDATE. fold vsrc in VALIDATE.
  fold vsrc in H1. fold c in H1. destruct (c!fs_lbl) eqn:CODE_FS; inv H1.
  destruct i; inv H0. repeat do_ok. rename d into tgt. rename v into vm_fs. rename l into next_fs.
  rename HDO0 into CODE_NEXT.
  set (vins := {| ver_code := (c # fs_lbl <- (Anchor tgt vm_fs (fresh_sug (Pos.succ fs_lbl) c))) #  (fresh_sug (Pos.succ fs_lbl) c) <- (Assume guard tgt vm_fs next_fs); ver_entry := ver_entry vsrc |}). fold vins in OPTV.
  apply Backward_internal_simulation with (bsim_order:=as_order) (bsim_match_states:=match_states p vsrc fid guard fs_lbl (fn_params f)).
  - apply wfounded.
  - unfold call_refl. unfold p_reflexive. intros s H. inv H. exists Zero. destruct ms. apply refl_match.
    apply match_stack_same.

  - intros. inv H1. inv H. econstructor. split. apply star_refl. constructor.

  - intros. eapply progress_preserved; eauto.

  - intros s2 t s2' STEP i0 s1 MATCH SAFE.
    inv MATCH.

    + rewrite OPT in OPTV. inv OPTV. (* assume_match *)
      inv STEP.
      2: { rewrite ANCHOR in AS_OPT. inv AS_OPT. }
      2: { rewrite ANCHOR in AS_OPT. inv AS_OPT. }
      simpl in STEP0. unfold ir_step, ir_int_step in STEP0.
      rewrite AS_OPT in STEP0. simpl in STEP0. repeat sdo_ok.
      destruct (bool_of_int i0) eqn:GUARD. inv HDO.
      * exists One. econstructor. split.    (* Assume holds *)
        ** left. apply plus_one. eapply Anchor_go_on; eauto.
        ** simpl. eapply opt_match; eauto.
           eapply def_analyze_correct; eauto. simpl; auto. unfold def_dr_transf. rewrite FS_SRC. auto.
      * repeat sdo_ok. exists Zero. econstructor. split. (* Assume fails *)
        ** left. apply plus_one. eapply Anchor_deopt; eauto.
        ** simpl. eapply refl_match. auto.

    + rewrite OPT in OPTV. inv OPTV. (* opt_match *)
      poseq_destr lbl fs_lbl.
      (* We are at the anchor used for insertion*)
      { assert (OPT': insert_assume_version vsrc fid guard fs_lbl (fn_params f)= OK vins) by auto.
        apply anchor_changed in OPT as [[fa la][vm [fresh [next [CODE_INS_FS [CODE_SRC_FS CODE_INS_AS]]]]]].
        unfold c in CODE_FS. rewrite CODE_FS in CODE_SRC_FS. inv CODE_SRC_FS. inv STEP.
        - unfold ir_step, ir_int_step in STEP0. rewrite CODE_INS_FS in STEP0. simpl in STEP0. inv STEP0.
        - rewrite ANCHOR in CODE_INS_FS. inv CODE_INS_FS.
        (* The Anchor goes on in OPT. In SRC, it will depend on how the Assume evaluates *)
        (* So we take a stuttering step in the SRC *)
          exists Zero. econstructor. split.
          + right. split. apply star_refl. constructor.
          + eapply assume_match; eauto.
        - rewrite ANCHOR in CODE_INS_FS. inv CODE_INS_FS.
        (* The Anchor deopts in both OPT and SRC *)
          exists Zero. econstructor. split.
          + left. apply plus_one. eapply Anchor_deopt; eauto.
          + eapply refl_match; eauto. }

      (* We are not at the Anchor used for insertion *)
      { eapply code_preservation in OPT as SAME_CODE; eauto.
        inv STEP.
        - unfold ir_step, ir_int_step in STEP0. repeat sdo_ok. destruct p0 as [t it].
          destruct i0; repeat sdo_ok.
          + exists One. econstructor. split.
            * left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
              rewrite SAME_CODE. simpl. eauto.
            * simpl. eapply opt_match; eauto. def_ok. rewrite SAME_CODE. auto.
          + exists One. econstructor. split.
            * left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
              rewrite SAME_CODE. simpl. rewrite HDO. simpl. eauto.
            * eapply opt_match; eauto. def_ok. rewrite SAME_CODE. auto.

          + simpl in HDO. repeat sdo_ok. unfold n_push_interpreter_stackframe in HDO0.
            simpl in HDO0. destruct top; inv HDO0.
            exists Zero. econstructor. split.
            * left. apply plus_one. eapply IR_step; eauto. unfold ir_step, ir_int_step.
              rewrite SAME_CODE. simpl. unfold sbind. unfold n_push_interpreter_stackframe.
              simpl. rewrite HDO. simpl. eauto.
            * simpl. eapply refl_match; eauto. constructor; auto.
              eapply frame_opt; eauto. intros. def_ok. rewrite SAME_CODE. apply define_insert. auto.
          + destruct (bool_of_int i0) eqn:BOOL; repeat sdo_ok.
            * exists One. econstructor. split.
              ** left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
                 rewrite SAME_CODE. simpl. rewrite HDO2. simpl. rewrite BOOL. simpl. eauto.
              ** eapply opt_match; eauto. def_ok. rewrite SAME_CODE. auto.
            * exists One. econstructor. split.
              ** left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
                 rewrite SAME_CODE. simpl. rewrite HDO2. simpl. rewrite BOOL. simpl. eauto.
              ** eapply opt_match; eauto. def_ok. rewrite SAME_CODE. auto.
          + exists Zero. econstructor. split.
            * left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
              rewrite SAME_CODE. simpl. rewrite HDO. simpl. eauto.
            * simpl. eapply refl_match; eauto.
          + exists One. econstructor. split.
            * left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
              rewrite SAME_CODE. simpl. rewrite HDO. simpl. eauto.
            * eapply opt_match; eauto. def_ok. rewrite SAME_CODE. apply define_insert. auto.
          + unfold n_memset in HDO3. destruct (Integers.Int.lt i0 mem_size) eqn:RANGE; inv HDO3.
            exists One. econstructor. split.
            * left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
              rewrite SAME_CODE. simpl. rewrite HDO. simpl. rewrite HDO2. simpl.
              unfold n_memset. rewrite RANGE. unfold sbind. simpl. eauto.
            * eapply opt_match; eauto. def_ok. rewrite SAME_CODE. auto.
          + unfold n_memget in HDO2. destruct (Integers.Int.lt i0 mem_size) eqn:RANGE; inv HDO2.
            destruct (heap ! (intpos.pos_of_int i0)) eqn:HEAP; inv H0.
            exists One. econstructor. split.
            * left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
              rewrite SAME_CODE. simpl. rewrite HDO. simpl.
              unfold n_memget. rewrite RANGE. unfold sbind. simpl. rewrite HEAP. eauto.
            * eapply opt_match; eauto. def_ok. rewrite SAME_CODE. apply define_insert. auto.
          + destruct d. repeat sdo_ok. destruct (bool_of_int i0) eqn:BOOL; repeat sdo_ok.
            * exists One. econstructor. split.
              ** left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
                 rewrite SAME_CODE. simpl. rewrite HDO2. simpl. rewrite BOOL. simpl. eauto.
              ** eapply opt_match; eauto. def_ok. rewrite SAME_CODE. auto.
            * exists Zero. econstructor. split.
              ** left. apply plus_one. eapply IR_step. unfold ir_step, ir_int_step.
                 rewrite SAME_CODE. simpl. rewrite HDO2. simpl. rewrite BOOL. rewrite HDO. simpl. eauto.
              ** simpl. eapply refl_match; eauto.
          + destruct d. inv HDO.

        - exists One. econstructor. split.
          + left. apply plus_one. eapply Anchor_go_on; eauto. rewrite SAME_CODE. apply ANCHOR.
          + eapply opt_match; eauto. clear CODE_NEXT CODE_FS. def_ok. rewrite ANCHOR in SAME_CODE.
            eauto. simpl; auto. rewrite SAME_CODE. rewrite ANCHOR. auto.
        - exists Zero. econstructor. split.
          + left. apply plus_one. eapply Anchor_deopt; eauto. rewrite SAME_CODE. eauto.
          + eapply refl_match. auto.
      }

    + { inv STEP.                 (* refl_match *)
        - destruct ms1. eapply addstk_same in STEP0 as [s [APP SAME]]; eauto.
          2: apply addstk_irstep.
          exists Zero. econstructor. split.
          + left. apply plus_one. eapply IR_step; eauto.
          + apply refl_match. subst. apply app_match; auto. apply match_stack_same.
        - destruct ms1. eapply addstk_same in STEP0 as [s [APP SAME]]; eauto.
          2: apply addstk_asmstep.
          exists Zero. econstructor. split.
          + left. apply plus_one. eapply x86_step; eauto.
          + apply refl_match. subst. apply app_match; auto. apply match_stack_same.
        - exists Zero. econstructor. split.
          + left. apply plus_one. eapply rtl_step; eauto.
          + apply refl_match; auto.
        - unfold find_function_ir in FINDOPTF.
          unfold set_version, set_version_funlist in GETF. simpl in GETF. rewrite FINDOPTF in GETF.
          poseq_destr fid fid0.
          +                     (* Calling the optimized function *)
            destruct ms2. eapply addstk_same in CALLEE as [s [APP SAME]].
            2: apply addstk_callee.
            simpl in NOT_COMPILED. unfold n_check_compiled in NOT_COMPILED. simpl in NOT_COMPILED.
            destruct (nc!fid0) eqn:NOT; inv NOT_COMPILED.
            destruct ms3. eapply addstk_same in ARGS as [s2 [APP2 SAME2]].
            rewrite PTree.gss in GETF. inv GETF.
            2: apply addstk_get_args.
            exists One. econstructor. split.
            * left. apply plus_one. eapply Call_IR; eauto; simpl.
              ** unfold n_check_compiled. simpl. rewrite NOT. eauto.
            * unfold validator in VALIDATE. fold c in VALIDATE. rewrite CODE_FS in VALIDATE. repeat do_ok.
              simpl.  rewrite current_version_set_version. eapply opt_match; eauto.
              ** apply app_match. apply app_match; auto. apply match_stack_same. apply match_stack_same.
              ** eapply def_analyze_init; eauto.
          +   (* calling another function *)
            rewrite PTree.gso in GETF; auto.
            destruct ms2. eapply addstk_same in CALLEE as [s [APP SAME]].
            2: apply addstk_callee.
            simpl in NOT_COMPILED. unfold n_check_compiled in NOT_COMPILED. simpl in NOT_COMPILED.
            destruct (nc!fid0) eqn:NOT; inv NOT_COMPILED.
            destruct ms3. eapply addstk_same in ARGS as [s2 [APP2 SAME2]].
            2: apply addstk_get_args.
            exists Zero. econstructor. split.
            * left. apply plus_one. eapply Call_IR; eauto; simpl.
              ** unfold n_check_compiled. simpl. rewrite NOT. eauto.
            * eapply refl_match. subst. apply match_app. apply match_app. auto.
        - destruct loc.
          + simpl in CALLEE. repeat sdo_ok. unfold n_load in HDO. simpl in HDO. destruct top; inv HDO.
            simpl in COMPILED. unfold n_check_compiled in COMPILED. simpl in COMPILED.
            destruct (nc ! (intpos.pos_of_int i0)) eqn:COMP; inv COMPILED.
            destruct ms3. eapply addstk_same in ARGS as [s [APP SAME]]; eauto.
            2: apply addstk_set_args.
            simpl in LOAD. repeat sdo_ok. unfold n_load_prog_code in HDO. simpl in HDO.
            rewrite COMP in HDO. inv HDO.
            exists Zero. econstructor. split.
            * left. apply plus_one. eapply Call_x86; eauto; simpl.
              ** unfold n_load, sbind. simpl. eauto.
              ** unfold n_check_compiled. simpl. rewrite COMP. eauto.
              ** unfold n_load_prog_code, sbind. simpl. rewrite COMP. eauto.
            * eapply refl_match. apply app_match; auto. apply match_stack_same.
          + simpl in CALLEE. inv CALLEE.
            simpl in COMPILED. unfold n_check_compiled in COMPILED. simpl in COMPILED.
            destruct (nc ! fid0) eqn:COMP; inv COMPILED.
            destruct ms3. eapply addstk_same in ARGS as [s [APP SAME]]; eauto.
            2: apply addstk_set_args.
            simpl in LOAD. repeat sdo_ok. unfold n_load_prog_code in HDO. simpl in HDO.
            rewrite COMP in HDO. inv HDO.
            exists Zero. econstructor. split.
            * left. apply plus_one. eapply Call_x86; eauto; simpl.
              ** unfold n_load, sbind. simpl. eauto.
              ** unfold n_check_compiled. simpl. rewrite COMP. eauto.
              ** unfold n_load_prog_code, sbind. simpl. rewrite COMP. eauto.
            * eapply refl_match. apply app_match; auto. apply match_stack_same.
        - inv RTL.
        - inv RTL_BLOCK.
        - destruct loc.
          + simpl in RETVAL; repeat sdo_ok. unfold n_load in HDO. simpl in HDO. destruct top; inv HDO.
            simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
            destruct top; inv OPEN_SF. destruct stk'; inv H0. destruct s; inv H1.
            2: { destruct a,p,p0,p. inv H0. }
            inv MATCHSTACK. inv MSF.
            * exists Zero. econstructor. split. (* Returning to the same function *)
              ** left. apply plus_one. eapply Return_IR; eauto.
                 *** simpl. unfold n_load, sbind. simpl. eauto.
                 *** simpl. unfold n_open_stackframe. simpl. eauto.
              ** eapply refl_match; eauto.
            * exists One. econstructor. split. (* Returning to the optimized IR *)
              ** left. apply plus_one. eapply Return_IR; eauto.
                 *** simpl. unfold n_load, sbind. simpl. eauto.
                 *** simpl. unfold n_open_stackframe. simpl. eauto.
              ** eapply opt_match; eauto.
          + simpl in RETVAL. inv RETVAL.
            simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
            destruct top; inv OPEN_SF. destruct stk'; inv H0. destruct s; inv H1.
            2: { destruct a,p,p0,p. inv H0. }
            inv MATCHSTACK. inv MSF.
            * exists Zero. econstructor. split. (* Returning to the same function *)
              ** left. apply plus_one. eapply Return_IR; eauto.
                 *** simpl. eauto.
                 *** simpl. unfold n_open_stackframe. simpl. eauto.
              ** eapply refl_match; eauto.
            * exists One. econstructor. split. (* Returning to the optimized IR *)
              ** left. apply plus_one. eapply Return_IR; eauto.
                 *** simpl. eauto.
                 *** simpl. unfold n_open_stackframe. simpl. eauto.
              ** eapply opt_match; eauto.
        - destruct loc.
          + simpl in RETVAL. repeat sdo_ok. unfold n_load in HDO. simpl in HDO. destruct top; inv HDO.
            simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
            destruct top; inv OPEN_SF. destruct stk'; inv H0. destruct s; inv H1. destruct a, p, p0, p.
            inv H0. simpl in SET_RETVAL. unfold n_save in SET_RETVAL. simpl in SET_RETVAL. inv SET_RETVAL.
            simpl in LOAD_CONT. repeat sdo_ok. destruct a.
            unfold n_load_prog_code in HDO. simpl in HDO. destruct (nc!(intpos.pos_of_int caller_fid)) eqn:LOAD; inv HDO.
            simpl in LOAD_CONT.
            destruct (t!(intpos.pos_of_int cont_lbl)) eqn:LOAD2; inv LOAD_CONT.
            inv MATCHSTACK. inv MSF.
            exists Zero. econstructor. split.
            * left. apply plus_one. eapply Return_x86; eauto; simpl.
              ** unfold n_load, sbind. simpl. eauto.
              ** unfold n_open_stackframe. simpl. eauto.
              ** unfold n_save. simpl. eauto.
              ** unfold n_load_prog_code, sbind. simpl.  rewrite LOAD. simpl. rewrite LOAD2. eauto.
            * eapply refl_match. auto.
          + simpl in RETVAL. inv RETVAL.
            simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
            destruct top; inv OPEN_SF. destruct stk'; inv H0. destruct s; inv H1. destruct a, p, p0, p.
            inv H0. simpl in SET_RETVAL. unfold n_save in SET_RETVAL. simpl in SET_RETVAL. inv SET_RETVAL.
            simpl in LOAD_CONT. repeat sdo_ok. destruct a.
            unfold n_load_prog_code in HDO. simpl in HDO. destruct (nc!(intpos.pos_of_int caller_fid)) eqn:LOAD; inv HDO.
            simpl in LOAD_CONT.
            destruct (t!(intpos.pos_of_int cont_lbl)) eqn:LOAD2; inv LOAD_CONT.
            inv MATCHSTACK. inv MSF.
            exists Zero. econstructor. split.
            * left. apply plus_one. eapply Return_x86; eauto; simpl.
              ** unfold n_load, sbind. simpl. eauto.
              ** unfold n_open_stackframe. simpl. eauto.
              ** unfold n_save. simpl. eauto.
              ** unfold n_load_prog_code, sbind. simpl.  rewrite LOAD. simpl. rewrite LOAD2. eauto.
            * eapply refl_match. auto.
        - inv RTL.
        - inv RTL_BLOCK.
        - destruct loc.
          + simpl in RETVAL. repeat sdo_ok. unfold n_load in HDO. simpl in HDO. destruct top; inv HDO.
            simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
            destruct top; inv OPEN_SF. destruct stk'; inv H0.
            2: { destruct s; inv H1. destruct a, p, p0, p. inv H0. }
            inv MATCHSTACK.
            exists Zero. econstructor. split.
            * left. apply plus_one. eapply Return_EOE; eauto; simpl.
              ** unfold n_load, sbind. simpl. eauto.
              ** unfold n_open_stackframe. simpl. eauto.
            * eapply refl_match; eauto. constructor.
          + simpl in RETVAL. inv RETVAL.
            simpl in OPEN_SF. unfold n_open_stackframe in OPEN_SF. simpl in OPEN_SF.
            destruct top; inv OPEN_SF. destruct stk'; inv H0.
            2: { destruct s; inv H1. destruct a, p, p0, p. inv H0. }
            inv MATCHSTACK.
            exists Zero. econstructor. split.
            * left. apply plus_one. eapply Return_EOE; eauto; simpl.
              ** unfold n_load, sbind. simpl. eauto.
              ** unfold n_open_stackframe. simpl. eauto.
            * eapply refl_match; eauto. constructor.
        - destruct ms1, ms2. eapply addstk_same in TARGET as [s [APP SAME]]; eauto.
          2: apply addstk_target.
          eapply addstk_same in BUILD_RM as [s2 [APP2 SAME2]]; eauto.
          2: apply addstk_build.
          unfold find_function_ir in FINDOPTF.
          unfold set_version, set_version_funlist in FINDF. simpl in FINDF.
          rewrite FINDOPTF in FINDF.
          poseq_destr ftgt fid.
          + exists Zero. econstructor. split.
            * left. apply plus_one. eapply Deopt; eauto; simpl.
            * rewrite PTree.gss in FINDF. inv FINDF. rewrite base_version_set_version.
              eapply refl_match; eauto. apply match_app. apply match_app. auto.
          + exists Zero. econstructor. split.
            * left. apply plus_one. eapply Deopt; eauto; simpl.
              ** rewrite PTree.gso in FINDF; eauto.
            * eapply refl_match; eauto. subst. apply match_app. apply match_app. auto.
        - destruct ms1. eapply addstk_same in PRIM_CALL as [s [APP SAME]].
          2: { unfold ASMinterpreter.prim_sem_dec. repeat addstk_auto. }
          exists Zero. econstructor. split.
          + left. apply plus_one. eapply RTL_prim; eauto.
          + eapply refl_match. subst. apply match_app. auto.
        - exists Zero. econstructor. split.
          + left. apply plus_one. eapply RTL_end; eauto.
          + eapply refl_match. auto.
        - exists Zero. econstructor. split.
          + left. apply plus_one. eapply RTL_block_end; eauto.
          + eapply refl_match. auto.
        - exists Zero. econstructor. split.
          + left. apply plus_one. eapply Anchor_go_on; eauto.
          + eapply refl_match. auto.
        - exists Zero. econstructor. split.
          + left. apply plus_one. eapply Anchor_deopt; eauto.
          + eapply refl_match. auto.
      }
Qed.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
From Heaps
Require Import pred prelude idynamic ordtype pcm finmap unionmap heap coding.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*

I'm not sure whether the I/O automata is the right model for this
task. Perhaps, we shoudl instead rethink the model in terms of
call/receive automata, which are similar to Disel's protocols in a way
they handle message passing. The only difference is that here we don't
have consider several communicating nodes, and instead work with just
one.

Thus, only "well-formed" messages get reacted to.

Furthermore, any transition can end with zero to n send messages
(i.e., calls), which will be sent in a non-deterministic order.

This should give enough space to implement the systems of
communicating contracts.

Next, we can proceed on making assertions for composing contracts ans
build on the research from the I/O automata community.

Finally, we will have to come up with a way to represent SC automata
in a language with exceptions and cost semantics, and compile it down
to EVM.

*)

(* Implementation of a simple state *)

Section State.

Definition value_type := nat.
Definition acc_id_type := nat.
Definition method_tag_type := nat.
Definition payload_type := (seq (nat * seq nat)).

(* Message with a payload *)
Record message :=
  Msg { value : value_type;
        sender : acc_id_type;
        method_tag : method_tag_type;
        payload :  payload_type
    }.

(* State of a contract *)
Record cstate (T : Type) :=
  CState {
      acc_id : acc_id_type;
      balance : value_type;
      state : T
    }.

End State.

Section Protocol.

(* Protocol operates on states of a predefined type T *)

Section Transitions.

(* State type *)
Variable S: Type.

Definition input_filter_type := message -> cstate S -> bool.

Definition resp_type :=
  (acc_id_type * value_type * method_tag_type * payload_type)%type.

Definition msg_bal (rt : resp_type) : value_type := rt.1.1.2.
Definition msg_bals outs := sumn (map msg_bal outs).

Definition trans_rel_type (input_filter : input_filter_type) :=
  forall m st1, input_filter m st1 ->
         forall (s2 : S) (outs : seq resp_type), Prop.

(* Contract transition in the spirit of I/O automata *)
Record ctransition :=
  CTrans {
      (* Unique tag of a transition in the protocol *)
      tag : method_tag_type;

      (* Decidable filter on incoming messages *)
      input_filter : input_filter_type;

      (* Relation between input and output state *)
      trans_rel : trans_rel_type input_filter;
    }.

End Transitions.

Record Protocol (S : Type) :=
  CProt {
      (*Account id *)
      acc_num : nat;
      (* Initial balance *)
      init_bal : nat;
      (* Initial state of a protocol *)
      init_state : S;
      (* Protocol comes with a set of transitions *)
      transitions : seq (ctransition S);
      (* All transitions have unique tags *)
      _ : uniq (map (@tag _) transitions)
    }.

(* TODO: Should we also say something about exclusivity of
         transition's preconditions? *)

(* TODO: Next, a program will have to be shown to refine a
         corresponding protocol. *)

End Protocol.

(***********************************************************)
(***              Protocol properties                    ***)
(***********************************************************)

Section Invariants.

Variable (S : Type) (p : Protocol S).

Notation s0 := (init_state p).
Notation acc := (acc_num p).
Notation b0 := (init_bal p).
Notation trans := (transitions p).

(* Definition of an inductive invariant with respect to a protocol p *)
(* Notice that the invariant updates the balance *)

Notation State := (cstate S).

Definition inductive (I : State -> Prop) :=
  (* A. Invariant holds in the initial state *)
  I (CState acc b0 s0) /\
  (* B. Any transition preserves the invariant *)
  forall ts, ts \In transitions p ->
  forall st1, I st1 ->
    forall m (pf : input_filter ts m st1) s2 outs,
    trans_rel pf s2 outs ->
  let bal' := (balance st1) - (msg_bals outs) + (value m) in
  I (CState acc bal' s2).

(* Here we assume that we always dispatch the messages, i.e., one
   cannot just transfer us money. *)

(* Determining whether we can reach s2 from s1 in one step *)
Definition can_step (st1 st2 : State) :=
  let: CState acc b1 s1 := st1 in
  exists ts m (pf : input_filter ts m st1) outs s2,
    [/\ ts \In transitions p,
     trans_rel pf s2 outs &
     let b2 := b1 - (msg_bals outs) + (value m) in
     st2 = CState acc b2 s2].

Fixpoint reachable' st1 st2 n :=
  if n is n'.+1
  then exists st, can_step st1 st /\ reachable' st st2 n'
  else st1 = st2.

Definition reachable st1 st2 := exists n, reachable' st1 st2 n.

(*****************************************************)
(*            Some modal connectives                 *)
(*****************************************************)

(* q holds since p becomes true *)
Definition since (p : State -> Prop) (q : State -> State -> Prop) :=
  forall st, p st -> forall st', reachable st st'-> q st st'.

(* TODO: can we come up with more sorts of invariants that have
   somewhat "temporal flavour?", e.g., in the spirit of eventual
   consistency. For instance, one should be able to prove that it's
   possible to withdraw money from th eaccount. *)

End Invariants.

(*************************************

Great story for compositionality: verify the "library" and then link
another contract against it and show that the joined interaction
always produces the same traces as it were only a client contract with
internal function.

This is still not equivalent to the usual execution because of limited
stack size. Thus, a call to library contract can fail, even if
everything is implemented correctly!

Wow.

Just wow.

 **************************************)

(************

Some more things to discuss or implement in the future:

* Formulate other sorts invariants for outgoing messages.

* Do we have to model the return value explicitly, or can we just
  represent it via message passing?

* How to fomulate the property that shouldn't be violated by the
  Puzzle contract from the Luu-al:CCS'16 paper?

  Perhaps, for this, we need a more "Concurrent" semantics, in which
  message sends are disparate from the corresponding contracts.

* Formalize the protocol of KoET contract and state the trace property
  that a previous king always gets correctly reimbursed. This would
  require to state properties over interactions between several
  parties.

* Start discussing a compiler from a back-end, verified with respect
  to a protocol.

*)


Require Import String. Import StringSyntax.
From Ling Require Import BSm2.
Import Ling.
From Ling Require Import Parasitic.
From Ling Require Import Covariance.

(* John scratched his arm, and bob did too *)

(* An analysis of sloppy identity that's similar to the covariance one *)

Definition scratched : TV := mkTV "scratched".

Parameter Of : DP -> DP -> DP.

Definition his : (DP >> S) || S -- (DP / DP) :=
  (fun k x => k (fun y => Of x y)).

Definition arm : DP := e "arm".
Definition bob : DP := e "bob".

(* strict reading *)
Eval compute in (lower ((lower (bind (lift john) <| ant1 (lift scratched |> (his |> lift arm))))
         <| (lift and |> (FOC bob <| did)))).

(* sloppy reading *)

Eval compute in (lower ((lower (lift john <| (ant0 (fill_dp (lift scratched |> (his |> lift arm)))))) <| (lift and |> (FOC bob <| did)))).


Require Import  Algebra.Utils Algebra.SetoidCat Algebra.Monad Algebra.Monoid  Algebra.Alternative Algebra.NearSemiRing  Algebra.Monad.ContT Algebra.Alternative Algebra.Functor Algebra.Applicative PairUtils SetoidUtils Tactics Algebra.SetoidCat.UnitUtils Algebra.Monoid.ArrUtils Algebra.Monad.Utils.

Require Import RelationClasses Relation_Definitions Morphisms SetoidClass.

Open Scope type_scope.

Section StoreHeap.
  Context
    {H : Type} {SH : Setoid H}
    {R : Type} {SR : Setoid R}
    {l lS}
    {alt : @Alternative l lS}
  .

  Definition storeHeap A {AS} := SH ~> SR ~~> SH ~*~ lS (R * A) (SR ~*~ AS).
  Instance storeHeapS {A} AS : Setoid (@storeHeap A AS) := SH ~~> SR ~~> SH ~*~ lS (R * A) (SR ~*~ AS).

  Definition sh {B} (BS : Setoid B) A {SA : Setoid A} := contT BS (@storeHeapS) A.
  Definition shS {B}  (BS : Setoid B) { A} (SA : Setoid A):= contTS BS (@storeHeapS) SA.

  Definition runSh {A B} {SA : Setoid A} {BS : Setoid B} : shS BS SA ~> (SA ~~> storeHeapS BS) ~~> storeHeapS BS := runContT.

  Existing Instance contT_Monad.

  Definition storeHeap_empty {A} {AS : Setoid A} : storeHeap A.
    simple refine (injF (fun h : H => constS SR @ (h, empty)) _).
    exact lS.
    exact alt.
    Lemma storeHeap_empty_1: forall {A} {AS : Setoid A}, Proper (equiv ==> equiv) (fun h : H => constS SR @ (h, empty)).
    Proof.
      intros. solve_proper.
    Qed.
    apply storeHeap_empty_1.
  Defined.

  Definition storeHeap_append {A} {AS : Setoid A} : storeHeapS AS ~> storeHeapS AS ~~> storeHeapS AS.
    simple refine (injF4 (fun (s1 s2 : storeHeap A) h r =>
                           let (h', l1) := s1 @ h @ r in
                           let (h'', l2) := s2 @ h' @ r in
                           (h'', l1 <|> l2)) _).
    exact lS.
    exact alt.
    Lemma storeHeap_append_1 : forall {A} {AS : Setoid A}, Proper (equiv ==> equiv ==> equiv ==> equiv ==> equiv)
     (fun (s1 s2 : storeHeap A) (h : H) (r : R) =>
      let (h', l1) := s1 @ h @ r in
      let (h'', l2) := s2 @ h' @ r in (h'', l1 <|> l2)).
    Proof.
      autounfold. intros. simpl_let. split. rewritesr. rewritesr.
    Qed.
    apply storeHeap_append_1.
  Defined.

  Instance storeHeap_Alternative : @Alternative (@storeHeap) (@storeHeapS).
  Proof.
    exists (@storeHeap_empty) (@storeHeap_append).
    intros. simpl. arrequiv. simpl_let. destruct (a @ a0 @ a1). rewrite left_unit_alt. split. reflexivity. reflexivity.
    intros. simpl. arrequiv. simpl_let. destruct (a @ a0 @ a1). rewrite right_unit_alt. split. reflexivity. reflexivity.
    intros. simpl. arrequiv. simpl_let. destruct (a @ a0 @ a1). simpl. destruct (b @ h @ a1).  simpl. split . reflexivity. rewrite associativity_alt. reflexivity.
  Defined.

  Instance sh_Monad {B} {BS : Setoid B} : @Monad (@sh B BS) (@shS B BS) := contT_Monad BS (@storeHeapS).

  Instance sh_Alternative {B} {BS : Setoid B} : @Alternative (@sh B BS) (@shS B BS) := contT_Alternative BS (@storeHeapS).

  Context
    {func : @Functor l lS}
    {app : @Applicative l lS func}.

  Definition getStore  {B} {BS : Setoid B} : sh BS R.
    simple refine (injF3 (fun (c : SR ~> storeHeapS BS) (h : H) (s : R)  => c @ s @ h @ s) _).
    Lemma getStore_1 : forall {B} {BS : Setoid B}, Proper (equiv ==> equiv ==> equiv ==> equiv)
                                 (fun (c : SR ~> storeHeapS BS) (h : H) (s : R) => c @ s @ h @ s).
    Proof.
      intros. solve_proper.
    Qed.
    apply getStore_1.
  Defined.

  Definition getHeap  {B} {BS : Setoid B} : sh BS H.
    simple refine (injF3 (fun (c : SH ~> storeHeapS BS) (h : H) (s : R)  => c @ h @ h @ s) _).
    Lemma getHeap_1 : forall {B} {BS : Setoid B}, Proper (equiv ==> equiv ==> equiv ==> equiv)
                                 (fun (c : SH ~> storeHeapS BS) (h : H) (s : R) => c @ h @ h @ s).
    Proof.
      intros. solve_proper.
    Qed.
    apply getHeap_1.
  Defined.

  Definition putStore  {B} {BS : Setoid B} : SR ~> shS BS unitS.
    simple refine (injF4 (fun (s : R) (c : unitS ~> storeHeapS BS) (h : H) (_ : R)  => c @ tt @ h @ s) _).
    Lemma putStore_1 : forall {B} {BS : Setoid B}, Proper (equiv ==> equiv ==> equiv ==> equiv ==> equiv)
     (fun (s : R) (c : unitS ~> storeHeapS BS) (h : H) (_ : R) =>
      c @ tt @ h @ s).
    Proof.
      autounfold. intros. rewritesr.
    Qed.
    apply putStore_1.
  Defined.

  Definition updateStore {B} {BS : Setoid B} : (SR ~~> SR) ~> shS BS unitS := (bind @ getStore) ∘ (flipS @ compS @ putStore).

  Definition putHeap  {B} {BS : Setoid B} : SH ~> shS BS unitS.
    simple refine (injF4 (fun (h : H) (c : unitS ~> storeHeapS BS) (_ : H) (s : R)  => c @ tt @ h @ s) _).
    Lemma putHeap_1 : forall {B} {BS : Setoid B}, Proper (equiv ==> equiv ==> equiv ==> equiv ==> equiv)
     (fun (h : H) (c : unitS ~> storeHeapS BS) (_ : H) (s : R) =>
      c @ tt @ h @ s).
    Proof.
      autounfold. intros. rewritesr.
    Qed.
    apply putHeap_1.
  Defined.

  Definition updateHeap {B} {BS : Setoid B} : (SH ~~> SH) ~> shS BS unitS := (bind @ getHeap) ∘ (flipS @ compS @ putHeap).

  Existing Instance arr_Monoid.
  Existing Instance contT_A_Monoid.

  Section Sh_SS_unitS_NearSemiRing.
    Definition sh_times {S : Type} {SS : Setoid S} : shS SS unitS ~> shS SS unitS ~~> shS SS unitS := andThen.

    Definition sh_plus {S : Type} {SS : Setoid S} : shS SS unitS ~> shS SS unitS ~~> shS SS unitS := mappend.

    Definition sh_zero {S : Type} {SS : Setoid S} : sh SS unit := mempty.

    Definition sh_one {S : Type} {SS : Setoid S}: sh SS unit := ret @ tt.

  Instance sh_NearSemiRing {S : Type} {SS : Setoid S} : @NearSemiRing _ (shS SS unitS).
  Proof.
    exists (sh_one) (sh_zero) (sh_times) (sh_plus).
    intros. simpl. arrequiv.
    intros. unfold sh_times, sh_one. unfold andThen. normalizecomp. unfold constS. normalize. apply (@right_unit_equiv (sh SS) (@shS _ SS) sh_Monad). simpl. arrequiv. destruct a0. reflexivity.
    intros. unfold sh_times. unfold andThen. normalizecomp. rewrite (@associativity (@sh S SS) (@shS _ SS) sh_Monad _ _ _ _ _ _ a (constS unitS @ b) (constS unitS @ c)). evalproper. simpl_equiv. reflexivity.
    intros. apply left_unit_monoid.
    intros. apply right_unit_monoid.
    intros. apply associativity_monoid.
    intros. simpl. arrequiv.
    intros. unfold sh_times at 1. unfold sh_plus at 1.  unfold andThen. normalizecomp. rewrite (@contT_left_distributivity _ _ _ _ _ _ _ _ _ a b (constS _ @ c)). reflexivity.
    Grab Existential Variables.
    solve_proper.
  Defined.

End Sh_SS_unitS_NearSemiRing.
  (* Proof. *)

  (* Proof. *)

(*

  Lemma concatMapM_cons : forall m0 (mnd : @Monad m0) A B (SA : Setoid A) (SB : Setoid B) (f : SA ~> m (listS SB)) (a : A) (l : list A), concatMapM @ f @ (a :: l) == appProper <$> f @ a <*> concatMapM @ f @ l.
  Proof.
    intros. simpl. repeat rewrite associativity_2. bindproper. unfold compM, injF2. simpl. arrequiv.
rewrite left_unit. simpl. normalize_monad. bindproper. normalize_monad.  reflexivity.
Grab Existential Variables.
solve_proper.
solve_proper.
  Qed.

  Lemma sequence_map_ret : forall m0 (mnd : @Monad m0) A B (SA : Setoid A) (SB : Setoid B) (l : list A) (f : A -> B), sequence (map (fun a => ret @ f a) l) == ret @ map f l.
  Proof.
    intros. induction l.
    simpl. reflexivity.
    intros. simpl. normalize_monad. rewrite IHl. rewrite left_unit. simpl. reflexivity.
  Qed.

  Lemma concatMapM_ret : forall m0 (mnd : @Monad m0) A  (SA : Setoid A)  pr (l : list A) (s : H), injective (listS SA) (m (listS SA)) ret -> concatMapM @ injF (fun a => ret @ (a :: nil)) pr  == ret .
  Proof.
    intros. simpl. arrequiv. induction a. simpl. normalize_monad. reflexivity.
    simpl. normalize_monad. rewrite <- associativity0. rewrite ret_ret. rewrite <- ret_ret with (f:=@concat A) (g:=app (a::nil)).
    assert (forall pr, injF (fun a1 => ret @ concat a1) pr == ret ∘ concatProper). intros. apply fun_ext. intros. reflexivity. rewrite H1.
    rewrite IHa. normalize_monad. reflexivity. solve_proper. solve_proper. solve_proper. solve_proper.
    Grab Existential Variables.
    solve_proper.
    solve_proper.
    solve_proper.
    solve_proper.
    solve_proper.
  Qed.

    Lemma concatMapM_nil : forall m0 (mnd : @Monad m0) A B (SA : Setoid A) (SB : Setoid B) (f : SA ~> m (listS SB)), concatMapM @ f @ nil == ret @ nil.
  Proof.
    intros. simpl. rewrite left_unit. simpl. reflexivity.
  Qed. *)

End StoreHeap.


(* PREAMBLE *)

From compcert.common             Require Events Builtins.
From trancert.properties         Require State Env.
From trancert.properties.memory  Require Alloc BindParameters Free.
From trancert.analysis           Require StateQuant.
From trancert.lib                Require All.
From trancert.simulations.memory.bijection
                                 Require Def AST Symbols.

Import common.AST Coqlib Csyntax Csem Events compcert.common.Memory.Mem
       compcert.common.Values properties.State Globalenvs Globalenvs.Genv
       properties.Env StateQuant lib.All Builtins ContinuationQuant memory.Alloc
       BindParameters bijection.Def bijection.AST bijection.Symbols.

Definition biject_extcall (sem: extcall_sem) (sg: signature) : Prop :=
        forall ge1 ge2 vargs m1 t vres m2 M m1' vargs',
          symbols_biject M ge1 ge2 ->
          sem ge1 vargs m1 t vres m2 ->
          biject M m1 m1' ->
          list_forall2 (biject_value (m_fwd M)) vargs vargs' ->
          exists M' vres' m2',
                sem ge2 vargs' m1' t vres' m2'
                /\ mapping_evolve M M'
                /\ biject_value (m_fwd M) vres vres'
                /\ biject M' m2 m2'
                /\ unchanged_on (loc_unmapped (m_fwd M)) m1 m2
                /\ unchanged_on (loc_out_of_reach (m_fwd M) m1) m1' m2'
                /\ inject_separated (m_fwd M) (m_fwd M') m1 m1'
                /\ inject_separated (m_bwd M) (m_bwd M') m1' m1
.

(** This record is used as a hypothesis in our proofs. It states that both builtin functions and external functions satisfy the additional constraints introduced above. *)

Definition biject_extcall_axiom := forall ef, biject_extcall (external_call ef) (ef_sig ef).


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Actions.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Framing with respect to the world *)

Module Injection.
Section Injection.

Variable W : world.

Structure injects (U V : world) (K : hooks) := Inject {
  (* The "delta world" *)
  E : world;

  _ : hook_complete U /\ hook_complete E;

  (* Additional hooks are included with an empty world *)
  _ : V = U \+ E \+ (Unit, K);

  (* Additional hooks are well-formed with respect to the world *)
  _ : hooks_consistent (getc (U \+ E)) K;

  (* These all should be easy to prove given a standard world disentanglement *)
  _ : forall s, Coh V s <-> exists s1 s2,
        [/\ s = s1 \+ s2, Coh U s1 & Coh E s2];

  (* Framing wrt. worlds and hooks *)
  _ : forall s1 s2 s this,
      s1 \+ s \In Coh V -> network_step U this s1 s2 ->
      network_step V this (s1 \+ s) (s2 \+ s);

  _ : forall s1 s2 s1' s2' this,
      s1 \In Coh U -> s2 \In Coh U ->
      network_step V this (s1 \+ s1') (s2 \+ s2') ->
      (network_step U this s1 s2   /\ s1' = s2') \/
      (network_step E this s1' s2' /\ s1 = s2); }.

End Injection.

Module Exports.
Section Exports.

Definition inj_ext := E.
Definition injects := injects.
Definition Inject := Inject.

Lemma cohK (U V : world) (K : hooks) (w : injects U V K) :
  V = U \+ inj_ext w \+ (Unit, K).
Proof. by case: w=>E/=. Qed.

Lemma cohE (U V : world) (K : hooks) (w : injects U V K) s :
  Coh V s <-> exists s1 s2,
      [/\ s = s1 \+ s2, Coh U s1 & Coh (inj_ext w) s2].
Proof. by case: w=>W ??? cohE sL sR; apply: cohE. Qed.

Lemma sem_extend (U V : world) (K : hooks) (w : injects U V K) s1 s2 s this:
      s1 \+ s \In Coh V -> s2 \+ s \In Coh V ->
      network_step U this s1 s2 -> network_step V this (s1 \+ s) (s2 \+ s).
Proof.
by case: w=>W _ _ _ cohE sL sR C G; apply: sL=>//.
Qed.

Lemma sem_split (U V : world) (K : hooks) (w : injects U V K) s1 s1' s2 s2' this:
      s1 \In Coh U -> s2 \In Coh U ->
      network_step V this (s1 \+ s1') (s2 \+ s2') ->
      (network_step U this s1 s2   /\ s1' = s2') \/
      (network_step (inj_ext w) this s1' s2' /\ s1 = s2).
Proof. by case: w=>W ??? cohE sl sR; apply: sR. Qed.

Definition extends (U V : world) (K : hooks) (w : injects U V K) s s1 :=
  exists s2, [/\ s = s1 \+ s2, s1 \In Coh U & s \In Coh V].

Notation dom_filt W := (fun k => k \in dom W).

(* TODO: prove something about hooks K being irrelevant for coherence *)

(* TODO: remove all irrelevant hooks *)

Definition projectS (W : world) (s : state) :=
  um_filter (dom_filt (getc W)) s.

Lemma projectS_cohL W1 W2 s :
  s \In Coh (W1 \+ W2) -> hook_complete W1 -> projectS W1 s \In Coh W1.
Proof.
case=>V1 V2 G1 D H G2; split=>//; first by move/validL: V1.
- by rewrite valid_umfilt.
- move=>z; case B: (z \in dom (getc W1)).
  + by rewrite dom_umfilt !inE B/= -D/=domUn !inE B/=; case/andP:V1=>->.
  by rewrite dom_umfilt !inE B.
move=>l; move: (H l)=>{H}H.
case B: (l \in dom (getc W1)); last first.
- rewrite /getProtocol /getStatelet; move: (B).
  case: dom_find=>//-> _.
  suff X: ~~(l \in dom (projectS W1 s)) by case: dom_find X=>//-> _.
  by rewrite /projectS dom_umfilt inE/= B.
have E1: find l s = find l (projectS W1 s).
- by rewrite /projectS/= find_umfilt B.
have E2: getProtocol (W1 \+ W2) l = getProtocol W1 l.
  - rewrite /getProtocol findUnL//?B//.
    by rewrite /valid/= in V1; case/andP: V1.
by rewrite -E2 /getStatelet -E1 in H *.
Qed.

Lemma projectS_cohR W1 W2 s :
  s \In Coh (W1 \+ W2) -> hook_complete W2 -> projectS W2 s \In Coh W2.
Proof. by rewrite joinC; apply: projectS_cohL. Qed.

Lemma projectSE W1 W2 s :
  s \In Coh (W1 \+ W2) ->
  s = projectS W1 s \+ projectS W2 s.
Proof.
case=>Vw Vs G D H; rewrite /projectS.
have X: {in dom s, dom_filt (getc W2) =1 predD (dom_filt (getc W2)) (dom_filt (getc W1))}.
- move=>z _/=; case I : (z \in dom (W1.1 \+ W2.1)).
  + move: I; rewrite domUn !inE/==>/andP[V']/orP[]Z; rewrite Z/=.
    - by case: validUn V'=>//_ _/(_ z Z)/=G' _;apply/negbTE.
    rewrite joinC in V'; case: validUn V'=>//_ _/(_ z Z)G' _.
    by rewrite andbC.
  move: I; rewrite domUn inE/==>/negbT; rewrite negb_and negb_or/=.
  have X: valid (W1 \+ W2) by [].
  by case/andP: X=>->/=_/andP[]->.
rewrite (eq_in_umfilt X) -umfilt_predU/=; clear X.
suff X: {in dom s, predU (dom_filt (getc W1)) (dom_filt (getc W2)) =1 predT}.
- by rewrite (eq_in_umfilt X) umfilt_predT.
by move=>z; rewrite/= -D domUn inE=>/andP[].
Qed.

Lemma coh_split W1 W2 s :
  s \In Coh (W1 \+ W2) ->
  hook_complete W1 -> hook_complete W2 ->
  exists s1 s2 : state,
    [/\ s1 \In Coh W1, s2 \In Coh W2 & s = s1 \+ s2].
Proof.
move=>C G1 G2; move/projectSE: (C)->.
exists (projectS W1 s), (projectS W2 s).
split=>//; [by apply: projectS_cohL C G1| by apply: projectS_cohR C G2].
Qed.

Lemma injExtL' (W1 W2 : world) K (pf : injects W1 (W1 \+ W2) K) :
  valid (W1 \+ W2) -> inj_ext pf \+ (Unit, K) = W2.
Proof.
move=>H; case: pf=>W2' _ E/=_ _ _ _.
rewrite -joinA in E.
case/andP: H=>H1 H2.
rewrite /PCM.join/= in H1 H2 E *.
case: W2 H1 H2 E=>/=c2 h2 H1 H2 [E1 E2].
by rewrite (joinxK H1 E1) (joinxK H2 E2).
Qed.

Lemma injExtR' W1 W2 K (pf : injects W2 (W1 \+ W2) K) :
  valid (W1 \+ W2) -> inj_ext pf \+ (Unit, K) = W1.
Proof.
move=>H; case: pf=>W2' _ E/= _ _ _ _.
rewrite -(joinC W2) in E H.
case/andP: H=>H1 H2; rewrite -joinA in E.
rewrite /PCM.join/= in H1 H2 E *.
case: W1 H1 H2 E=>/=c1 h1 H1 H2 [E1 E2].
by rewrite (joinxK H1 E1) (joinxK H2 E2).
Qed.

Lemma injExtL W1 W2 (pf : injects W1 (W1 \+ W2) Unit) :
  valid (W1 \+ W2) -> inj_ext pf = W2.
Proof. by move/(injExtL' pf); rewrite unitR. Qed.

Lemma injExtR W1 W2 (pf : injects W2 (W1 \+ W2) Unit) :
  valid (W1 \+ W2) -> inj_ext pf  = W1.
Proof. by move/(injExtR' pf); rewrite unitR. Qed.

End Exports.
End Exports.

End Injection.

Export Injection.Exports.

Module InjectExtra.

Lemma cohUnKR U W s s':
  s \+ s' \In Coh (U \+ W) -> s \In Coh U ->
  hook_complete W -> s' \In Coh W.
Proof.
move=>H C G2; move: (cohH C) => G1.
suff X: s' = projectS W (s \+ s').
- by rewrite X; apply: (projectS_cohR H).
suff X: s = projectS U (s \+ s').
- move: (cohS H)=>V; move/projectSE: (H)=>E.
  rewrite E in V.
  rewrite {1}X in E.
  by rewrite (joinxK V (sym_eq E)).
rewrite /projectS.
suff X: {in dom (s \+ s'), dom U.1 =i dom s}.
- by rewrite (eq_in_umfilt X) umfilt_dom ?(cohS H)//.
by move=>z _; move: (cohD C z); rewrite /in_mem.
Qed.

Lemma cohUnKL U W s s':
  s \+ s' \In Coh (U \+ W) -> s' \In Coh W ->
  hook_complete U -> s \In Coh U .
Proof.
by move=>H C G1; rewrite [U \+ W]joinC [s\+_]joinC in H; apply: (cohUnKR H).
Qed.

Lemma getPUn (U W : world) l :
  valid (U \+ W) -> l \in dom U.1 ->
  getProtocol U l = getProtocol (U \+ W) l.
Proof.
move=>V; rewrite /getProtocol=>D.
case/andP: (V)=>V1 V2.
by rewrite findUnL ?V1// D.
Qed.

Lemma getSUn s1 s2 l :
  valid (s1 \+ s2) -> l \in dom s1 ->
  getStatelet s1 l = getStatelet (s1 \+ s2) l.
Proof.
move=>V; rewrite /getStatelet=>D.
by rewrite findUnL ?V// D.
Qed.

Lemma hook_completeL (U : world) K :
  valid (U \+ (Unit, K)) ->
  hook_complete (U \+ (Unit, K)) -> hook_complete U.
Proof.
case: U=>c h=> V H z lc ls st D.
move: (H z lc ls st); rewrite domUn inE/= D/=.
case/andP: V=>_->/==>/(_ is_true_true)=>/andP[].
by rewrite !unitR=>->->.
Qed.

Lemma get_protocol_hooks (U: world) K l:
  valid U -> getProtocol (U \+ (Unit, K)) l = getProtocol U l.
Proof.
move=>V; rewrite /getProtocol.
by rewrite findUnR ?dom0 ?inE//; rewrite unitR; case/andP: V.
Qed.

Lemma coh_hooks (U : world) K s :
  s \In (Coh (U \+ (Unit, K))) -> s \In (Coh U).
Proof.
case=>V Vs Hk D L.
split=>//; first by move/validL: V.
- by apply: hook_completeL V Hk.
- move=>z; rewrite -D domUn !inE/= unitR dom0 orbC/=.
  by move/validL:V=>/andP[]->_.
by move=>l; move: (L l); rewrite (get_protocol_hooks K l (validL V)).
Qed.

Lemma inj_hooks_complete (U W : world) K:
  valid (U \+ W \+ (Unit, K)) ->
  hook_complete U -> hook_complete W ->
  hooks_consistent (U \+ W).1 K ->
  hook_complete (U \+ W \+ (Unit, K)).
Proof.
move=>V G1 G2 G.
move=>z lc ls st; rewrite domUn !inE/= !unitR.
move/andP: (V)=>[_]->/=; case/orP; last by move/G.
rewrite !domUn !inE; case/validL/andP:V=>->->/=.
case/orP; first by case/G1/andP=>->->.
by case/G2/andP=>->->; rewrite -!(orbC true).
Qed.

Lemma inject_step U W K this s1 s2 s1' s2' :
  valid (U \+ W) ->
  s1 \In Coh U -> s2 \In Coh U ->
  hook_complete U -> hook_complete W ->
  network_step (U \+ W \+ (Unit, K)) this (s1 \+ s1') (s2 \+ s2') ->
  network_step U this s1 s2 /\ s1' = s2' \/
  network_step W this s1' s2' /\ s1 = s2.
Proof.
move=>V C1 C2 Hu Hw S; move/step_coh: (S)=>[C1' C2'].
move: (cohW C1')=>V1.
move: (coh_hooks C1')(coh_hooks C2')=>{C1'}C1'{C2'}C2'.
move: (cohUnKR C1' C1 Hw) (cohUnKR C2' C2 Hw)=>D1 D2.
case: S; first 2 last.

(* Receive Step *)
move=>l rt R i from H1.
rewrite domUn inE=>/andP[Vs]/=/orP; case=>D C msg H2 [H3 H4]/=;
[rewrite updUnL D|rewrite updUnR D]=>G;[left|right].
- have X: s1' = s2'.
  + move: (C2'); rewrite (joinC U) G -[upd _ _ _ \+ s1'](joinC s1').
    move/cohUnKR/(_ D1)/(_ Hu)=>C1''.
    move: (coh_prec (cohS C2') C2 C1'' G)=>Z; rewrite -Z in G; clear Z.
    by rewrite (joinxK (cohS C2') G).
  split=>//; subst s2'; rewrite -![_ \+ s1'](joinC s1') in G C2'.
  rewrite -[upd _ _ _ \+ s1'](joinC s1') in G; rewrite (joinC U) in C2'.
  move: (joinxK (cohS C2') G)=>{G}G.
  have E: getProtocol U l = getProtocol (U \+ W) l.
    by rewrite (getPUn V)// (cohD C1).
  have E': getStatelet s1 l = getStatelet (s1 \+ s1') l.
    by rewrite (getSUn (cohS C1')).
  rewrite /get_rt /InMem/= in R.
  move: (getStatelet (s1 \+ s1') l) E' C (coh_s l C) H1 G H3 H4=>_<-_.
  move: (getProtocol (U \+ W \+ (Unit, K)) l)
        (get_protocol_hooks K l V) E rt R H2=>_-><-rt R H2 coh_s H1 G H3 H4.
  apply: (ReceiveMsg R D H2 (i := i) (from := from) (s2 := s2) (C := C1)).
  split=>//=; move: (NetworkSem.coh_s l C1)=>coh_s';
  by rewrite -(pf_irr coh_s coh_s').

(* Second part or receive-step *)
move: U W V {V1} Hw Hu s1 s2 s1' s2' C1 C2 C1' C2' D1 D2 rt H1 H2 Vs D C R H3 H4 G.
move=>W U V Hw Hu s1' s2' s1 s2 D1 D2.
rewrite !(joinC W) -!(joinC s1) -!(joinC s2)=> C1' C2' C1 C2.
move=>rt H1 H2 Vs D C R H3 H4 G.
have X: s1' = s2'.
- move: (C2'); rewrite (joinC U) G.
  move/cohUnKR/(_ D1)/(_ Hw)=>C1''; rewrite (joinC s1') in G.
  move: (coh_prec (cohS C2') C2 C1'' G)=>Z; rewrite -Z in G; clear Z.
  by rewrite (joinxK (cohS C2') G).
split=>//; subst s2'; rewrite -!(joinC s1') in G C2'.
rewrite (joinC U) in C2'; move: (joinxK (cohS C2') G)=>{G}G.
rewrite joinC in V.
have E: getProtocol U l = getProtocol (U \+ W) l.
  by rewrite (getPUn V)// (cohD C1).
have E': getStatelet s1 l = getStatelet (s1 \+ s1') l.
  by rewrite (getSUn (cohS C1')).
rewrite /get_rt /InMem/= in R.
move: (getStatelet (s1 \+ s1') l) E' C (coh_s l C) H1 G H3 H4=>_<-_.
move: (getProtocol (U \+ W \+ (Unit, K)) l)
      (get_protocol_hooks K l V) E rt R H2=>_-><-rt R H2 coh_s H1 G H3 H4.
apply: (ReceiveMsg R D H2 (i := i) (from := from) (s2 := s2) (C := C1)).
split=>//=; move: (NetworkSem.coh_s l C1)=>coh_s';
by rewrite -(pf_irr coh_s coh_s').

(* Idle Step *)
- case=>_ E; move: (coh_prec (cohS C1') C1 C2 E)=>Z; subst s2.
  rewrite (joinC U) (joinC s1) in C1'; rewrite !(joinC s1) in E.
  move: (coh_prec (cohS C1') D1 D2 E)=>Z; subst s2'.
  by left; split=>//; apply: Idle.

(* Send Step *)
- move=>l st H1 to msg h H2.
  rewrite domUn inE=>/andP[Vs]/orP; case=> D _ S Hk H3;
  [rewrite updUnL D|rewrite updUnR D]=>G;[left|right];
  [| move: U W V1 Hu Hw V s1 s2 s1' s2' C1 C2 C1' C2' D1 D2 st Hk H1 H2 Vs D S H3 G;
    move=> W U V1 Hw Hu V s1' s2' s1 s2 D1 D2 C1' C2' C1 C2 st Hk H1 H2 Vs D S H3 G;
     rewrite (joinC W) in V C1' C2' st H1 S H3 G H2 Hk;
     rewrite -?(joinC s1) -?(joinC s2) in C1' C2' S G H3 Vs].
  + have X: s1' = s2'.
    - move: (C2'); rewrite (joinC U) G -[upd _ _ _ \+ s1'](joinC s1').
      move/cohUnKR/(_ D1)/(_ Hu)=>C1''.
      move: (coh_prec (cohS C2') C2 C1'' G)=>Z; rewrite -Z in G; clear Z.
      by rewrite (joinxK (cohS C2') G).
    split=>//; subst s2'; rewrite -!(joinC s1') in G C2'.
    rewrite (joinC U) in C2'; move: (joinxK (cohS C2') G)=>{G}G.
    rewrite (joinC s1') in G.
    have E: getProtocol U l = getProtocol (U \+ W) l.
      by rewrite (getPUn V)// (cohD C1).
    have E': getStatelet s1 l = getStatelet (s1 \+ s1') l.
      by rewrite (getSUn Vs).
    rewrite /get_st /InMem in H1.
    move: (getStatelet (s1 \+ s1') l) (E') H2 S H3 G=>_<- H2 S H3 G.
    move: (getProtocol (U \+ W \+ (Unit, K)) l)
     (get_protocol_hooks K l V) E st H1 S H2 H3 G Hk=>_-><- st H1 S H2 H3 G Hk.
    apply: (SendMsg H1 H2 D C1 _ H3 G).

    (* Now proving the obligation about all_hooks_fire *)
    move=>z lc hk F A1 A2.
    apply sym_eq in F.
    move: (Hk z lc hk).
    rewrite -F -joinA !domUn !inE !Vs A1 A2 findUnL ?E' ?(find_some F)/=;
      last by case/andP:V1; rewrite-joinA =>_->.
    move/(_ erefl is_true_true is_true_true).
    by rewrite {1 3}/getStatelet findUnL// A1.

  have X: s1' = s2'.
  - move: (C2'); rewrite (joinC U) G.
    move/cohUnKR/(_ D1)/(_ Hu)=>C1''; rewrite (joinC s1') in G.
    move: (coh_prec (cohS C2') C2 C1'' G)=>Z; rewrite -Z in G; clear Z.
    by rewrite (joinxK (cohS C2') G).
  split=>//; subst s2'; rewrite -!(joinC s1') in G C2'.
  rewrite (joinC U) in C2'; move: (joinxK (cohS C2') G)=>{G}G.
  rewrite (joinC s1') in G.
  have E: getProtocol U l = getProtocol (U \+ W) l.
    by rewrite (getPUn V)// (cohD C1).
  have E': getStatelet s1 l = getStatelet (s1 \+ s1') l.
    by rewrite (getSUn Vs).
  rewrite /get_st /InMem in H1; rewrite (joinC s1') in H2.
    move: (getStatelet (s1 \+ s1') l) (E') H2 S H3 G=>_<- H2 S H3 G.
    move: (getProtocol (U \+ W \+ (Unit, K)) l)
     (get_protocol_hooks K l V) E st H1 S H2 H3 G Hk=>_-><- st H1 S H2 H3 G Hk.
    apply: (SendMsg H1 H2 D C1 _ H3 G).

    (* Now proving the obligation about all_hooks_fire *)
    move=>z lc hk F A1 A2.
    apply sym_eq in F.
    move: (Hk z lc hk).
    rewrite -F -joinA !domUn !inE A1 A2 findUnL ?E' ?(find_some F)/=;
      last by rewrite joinA (joinC U.2); case/andP:V1=>_->.
    rewrite !(joinC s1') !Vs/= -!(orbC true).
    move/(_ erefl is_true_true is_true_true).
    by rewrite {1 3}/getStatelet findUnL// A1.
Qed.

(* The following two definitions are central for framing with respect
to the hooks. In essence. we can add more hooks via the frame rule, if
none of the protocols in the "core" world (i.e., the world, to which
we attach the frame with more hooks) are going to become constrained
by the newly added hooks.

In other words, the new hooks only constrain the world "to be
attached" but not our "core" world. *)

Definition not_hooked_by (K : hooks) l :=
  forall z lc l' st, (z, lc, (l', st)) \in dom K -> l != l'.

Definition world_not_hooked (W: world) K :=
  forall l, l \in dom W.1 -> not_hooked_by K l.

Lemma hooks_frame (U W : world) (K : hooks) l st s s' n msg to :
  hook_complete U -> hook_complete W ->
  hooks_consistent (U \+ W).1 K ->
  l \in dom s -> s \In Coh U -> s \+ s' \In Coh (U \+ W \+ (Unit, K)) ->
  not_hooked_by K l ->
  all_hooks_fire (geth U) l st s n msg to ->
  all_hooks_fire (geth (U \+ W \+ (Unit, K))) l st (s \+ s') n msg to.
Proof.
move=>G1 G2 G D' C1 C' N A z lc hk F D1 D2; move: F.
case/andP: (cohW C')=>/=V1 V2.
move: (cohUnKR (coh_hooks C') C1 G2) => C2.
rewrite findUnL ?V2//=; case: ifP=>D3; last first.
- move => F; apply sym_eq in F; move: F.
  by move/find_some/N/negP; rewrite eqxx.
rewrite findUnR ?(validL V2)//; case: ifP=>[D|_].
+ case/G2/andP: D=>_ D; rewrite (cohD C2) in D.
  by case: validUn (cohS C')=>//_ _/(_ _ D'); rewrite D.
move => F.
apply sym_eq in F.
have D'': lc \in dom s by case/andP:(G1 _ _ _ _ (find_some F)); rewrite (cohD C1).
have E: getStatelet s l = getStatelet (s \+ s') l
  by rewrite (getSUn (cohS C'))// -?(cohD C1').
have E': getStatelet s lc = getStatelet (s \+ s') lc.
  by rewrite (getSUn (cohS C'))// -?(cohD C1').
move: (getStatelet (s \+ s') l) (getStatelet (s \+ s') lc) E E'.
by move=>y1 y2 Z1 Z2; subst y1 y2; apply sym_eq in F; apply: (A z).
Qed.

(********************************************************************)
(*                      Framing result                              *)
(********************************************************************)

Lemma inject_frame U W K this s1 s2 s:
  s1 \+ s \In Coh (U \+ W \+ (Unit, K)) ->
  network_step U this s1 s2 ->
  hook_complete U -> hook_complete W ->
  hooks_consistent (U \+ W).1 K ->
  (* State something about hook direction *)
  world_not_hooked U K ->
  network_step (U \+ W \+ (Unit, K)) this (s1 \+ s) (s2 \+ s).
Proof.
move=>C1 S Ku Kw Hk N; move/step_coh: (S)=>[C1' C2'].
case: S; first by move=>[_ <-]; apply: Idle.

(* Send-transition *)
- move=>l st H1 to msg h H2 H3 _ S A H4 G.
  have E: getProtocol U l = getProtocol (U \+ W \+ (Unit, K)) l.
  have Y: getProtocol U l = getProtocol (U \+ W) l.
    + by rewrite (getPUn (validL (cohW C1)))// (cohD C1').
    rewrite Y; rewrite (getPUn (cohW C1))// domUn inE (cohD C1') H3/=.
    by case/andP: (validL (cohW C1))=>->.
  have E': getStatelet s1 l = getStatelet (s1 \+ s) l.
    by rewrite (getSUn (cohS C1))// -?(cohD C1').
  have X: l \in dom (s1 \+ s) by rewrite domUn inE H3 (cohS C1).
  move: (getProtocol U) (E) H2=>_ -> H2.
  rewrite /get_st /InMem/= in H1.
  rewrite E' in H2 G S H4; clear E'.
  move: (getProtocol U l) E st H1 S H4 G H2 A=>_->st H1 S H4 G H2 A.
  apply: (SendMsg H1 H2 X C1 _ H4 (s2 := s2 \+ s)); last first.
  - by rewrite updUnL H3; congr (_ \+ _).
  by apply: hooks_frame=>//; apply: N; rewrite -(cohD C1') in H3.

(* Receive-transition *)
move=> l rt H1 msg from H2 H3 C tms G [G1 G2/= G3].
have E: getProtocol U l = getProtocol (U \+ W \+ (Unit, K)) l.
  have Y: getProtocol U l = getProtocol (U \+ W) l.
  - by rewrite (getPUn (validL (cohW C1)))// (cohD C1').
  rewrite Y; rewrite (getPUn (cohW C1))// domUn inE (cohD C1') H3/=.
  by case/andP: (validL (cohW C1))=>->.
have E': getStatelet s1 l = getStatelet (s1 \+ s) l.
  by rewrite (getSUn (cohS C1))// -?(cohD C1').
have X: l \in dom (s1 \+ s) by rewrite domUn inE (cohS C1) H3.
rewrite /get_rt /InMem /= in H1.
move: (getProtocol U l) (getStatelet s1 l) E E' C H2
      (coh_s l C) rt G3 G G2 H1 G1=>z1 z2 Z1 Z2.
subst z1 z2=>C pf C' G3 G G2 H1 H2 G1.
apply: (ReceiveMsg H2 X G2 (i := msg) (from := from) (s2 := s2 \+ s)).
split=>//=; first by rewrite (pf_irr (coh_s l C1) C').
rewrite updUnL H3; congr (_ \+ _); move: (NetworkSem.coh_s l C1)=>pf'.
by rewrite (pf_irr pf' C').
Qed.

Lemma injectL (U W : world) K :
  valid (U \+ W \+ (Unit, K)) ->
  hook_complete U -> hook_complete W ->
  hooks_consistent (getc (U \+ W)) K ->
  world_not_hooked U K ->
  injects U (U \+ W \+ (Unit, K)) K.
Proof.
move=>H G1 G2 G N.
exists W=>//[s|s1 s2 s this|s1 s2 s1' s2' this]; [split | |].
- move/coh_hooks=>C; exists (projectS U s), (projectS W s).
  split; [by apply projectSE|by apply: (projectS_cohL C)|
          by apply: (projectS_cohR C)].
- case=>s1[s2][Z]C1 C2; subst s.
  have W1 : valid (s1 \+ s2).
  + case: validUn; rewrite ?(cohS C1) ?(cohS C2)//.
    move=>l; rewrite -(cohD C1)-(cohD C2).
    case/validL/andP: H=>H _;
    by case: validUn H=>//_ _/(_ l) G' _/G'; move/negbTE=>->.
  split=>//[||l].
  + by apply: inj_hooks_complete.
  + move=>l; rewrite !domUn !inE !unitR dom0 orbC/=.
    rewrite W1/= -(cohD C1)-(cohD C2) domUn !inE//=.
    by move/validL/andP:H=>[->]_.
  + rewrite (get_protocol_hooks K l (validL H)).
    rewrite /getProtocol/getStatelet !findUnL//; last by case/validL/andP:H.
    by rewrite (cohD C1); case B: (l \in dom s1)=>//; apply: coh_coh.
- by move=>C1 C2; apply: inject_frame.
by move=>C1 C2; apply: (inject_step (validL H)).
Qed.

Lemma injectR (U W : world) K :
  valid (W \+ U \+ (Unit, K)) ->
  hook_complete U -> hook_complete W ->
  hooks_consistent (getc (U \+ W)) K ->
  world_not_hooked U K ->
  injects U (W \+ U \+ (Unit, K)) K.
Proof. by rewrite (joinC W); apply: injectL. Qed.

Lemma locProjL (W1 W2 : world) l s1 s2:
  (s1 \+ s2) \In Coh (W1 \+ W2) -> l \in dom W1.1 ->
  s1 \In Coh W1 -> getStatelet (s1 \+ s2) l = getStatelet s1 l.
Proof.
move=>C D C1; rewrite (cohD C1) in D.
by rewrite (getSUn (cohS C) D).
Qed.

Lemma locProjR (W1 W2 : world) l s1 s2:
  (s1 \+ s2) \In Coh (W1 \+ W2) -> l \in dom W2.1 ->
  s2 \In Coh W2 -> getStatelet (s1 \+ s2) l = getStatelet s2 l.
Proof. by rewrite !(joinC W1) !(joinC s1); apply: locProjL. Qed.

End InjectExtra.

Export InjectExtra.


From ITree Require Import ITree.
From Paco Require Import paco.
From compcert Require Import Integers.

Require Import sflib.

Require Import StdlibExt.
Require Import IntegersExt.
Require Import SyncSysModel.
Require Import CProgEventSem.
Require Import Executable.
Require Import PALSSystem.

From Coq Require Extraction ExtrOcamlBasic ExtrOcamlString.
Require Import ZArith List Lia.

Definition resize_bytes (sz: nat): bytes -> bytes? :=
  (fun bs => Some (RTSysEnv.resize_bytes sz bs)).

Definition generic_itree: @ExecutableSpec.t obsE bytes ->
                          Z -> option Z -> itree _ unit :=
  ExecutableSpec.sys_itree.

Cd "./extr/generic".
Extraction "Generic.ml" resize_bytes generic_itree.
Cd "../..".