Require Import Core.Core Core.VstTactics Core.StructNormalizer VstLib
        ErrorWithWriter.
Require Import Core.Tactics.

Require Import VST.floyd.proofauto.
Require Import Clight.ber_tlv_tag Exec.Ber_tlv_tag_serialize.
Require Import Core.Notations Core.SepLemmas.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. Proof. mk_varspecs prog. Defined.

Open Scope Z.

Definition ber_tlv_tag_serialize_spec : ident * funspec :=
  DECLARE _ber_tlv_tag_serialize
  WITH tag : int, buf_b : block, buf_ofs : ptrofs, buf_size : Z
  PRE[tuint, tptr tvoid, tuint]
    PROP(buf_size = 0 \/ buf_size = 32;
         Ptrofs.unsigned buf_ofs + buf_size < Ptrofs.modulus)
    PARAMS(Vint tag; (Vptr buf_b buf_ofs); Vint (Int.repr buf_size))
    GLOBALS()
    SEP(data_at Tsh (tarray tuchar buf_size)
                    (default_val (tarray tuchar buf_size))
                    (Vptr buf_b buf_ofs))
  POST[tuint]
    PROP()
    LOCAL(temp ret_temp
               (Vint (Int.repr (snd (tag_serialize tag (Int.repr buf_size))))))
    SEP(let (ls, z) := tag_serialize tag (Int.repr buf_size) in
        data_at Tsh (tarray tuchar buf_size)
                         (map Vint ls
                              ++ sublist (len ls) buf_size
                             (default_val (tarray tuchar buf_size)))
                         (Vptr buf_b buf_ofs)).

Definition Gprog := ltac:(with_library prog [ber_tlv_tag_serialize_spec]).

Open Scope IntScope.

Theorem ber_tlv_tag_serialize_correct :
  semax_body Vprog Gprog (normalize_function f_ber_tlv_tag_serialize composites)
             ber_tlv_tag_serialize_spec.
Admitted.
(* Proof.
  start_function.
  remember (Int.shru tag (Int.repr 2)) as tval.
  remember (Int.zero_ext 8 (((tag & Int.repr 3) << Int.repr 6) or tval)) as e0.
  remember (default_val (tarray tuchar buf_size)) as default_list.
  remember (Int.zero_ext 8 (((tag & Int.repr 3) << Int.repr 6) or Int.repr 31)) as e1.
  assert (len default_list = buf_size) as LB.
  {  subst; unfold default_val;
        simpl;
        try erewrite Zlength_list_repeat;
        try nia; auto. }
  pose proof (req_size_32 tval) as R.
  repeat forward.
  forward_if.
  - forward_if (
       PROP()
       LOCAL()
       SEP(if eq_dec (Int.repr buf_size) 0
           then data_at_ Tsh (tarray tuchar buf_size) (Vptr buf_b buf_ofs)
           else data_at Tsh (tarray tuchar buf_size)
                        (upd_Znth 0 (default_val (tarray tuchar buf_size))
                                  (Vint e0)) (Vptr buf_b buf_ofs))).
    + forward.
      rewrite_if_b.
      entailer!.
    + forward.
      rewrite_if_b.
      entailer!.
    + unfold POSTCONDITION.
      unfold abbreviate.
      try break_let.
      forward.
     break_if; unfold tag_serialize in *.
     replace (30 >=? Int.unsigned (tag >>u Int.repr 2)) with true in *.
     rewrite_if_b.
     inversion Heqp.
     entailer!.
     autorewrite with sublist.
     erewrite sublist_same_gen.
     entailer!.
     lia.
     setoid_rewrite LB. lia.
     symmetry.
     Zbool_to_Prop.
     lia.
     replace (30 >=? Int.unsigned (tag >>u Int.repr 2)) with true in *.
     rewrite_if_b.
     inversion Heqp.
     entailer!.
     erewrite upd_Znth_unfold.
     setoid_rewrite LB.
     entailer!.
     setoid_rewrite LB.
     assert (buf_size <> 0%Z).
     eapply repr_neq_e in n; try lia.
     lia.
     symmetry.
     Zbool_to_Prop.
     lia.
  - (* 30 < tag *)
    forward_if (
       PROP()
       LOCAL(if eq_dec (Int.repr buf_size) 0
             then temp _buf__1 (Vptr buf_b buf_ofs)
             else temp _buf__1 (offset_val 1 (Vptr buf_b buf_ofs));
             if eq_dec (Int.repr buf_size) 0
             then temp _size (Vint (Int.repr buf_size))
             else temp _size (Vint (Int.repr (buf_size - 1)));
            temp _tval (Vint tval))
       SEP(if eq_dec (Int.repr buf_size) 0
           then data_at Tsh (tarray tuchar buf_size)
                     (default_val (tarray tuchar buf_size)) (Vptr buf_b buf_ofs)
           else data_at Tsh (tarray tuchar buf_size)
                        (upd_Znth 0 (default_val (tarray tuchar buf_size))
                                  (Vint e1)) (Vptr buf_b buf_ofs))).
    + rewrite <- LB.
      erewrite split_data_at_sublist_tuchar with (j := 1%Z).
      erewrite sublist_one.
      erewrite data_at_tuchar_singleton_array_eq.
      Intros.
      repeat forward.
      repeat rewrite_if_b.
      entailer!.
      replace (len (default_val (tarray tuchar buf_size))) with buf_size.
      auto.
      erewrite upd_Znth_unfold.
      erewrite sublist_nil.
      erewrite app_nil_l.
      remember (default_val (tarray tuchar buf_size)) as default_list.
      remember (Int.zero_ext 8 (((tag & Int.repr 3) << Int.repr 6) or Int.repr 31)) as e1.
      erewrite <- split_non_empty_list with
          (j1 := buf_size)
          (ls :=  ([Vint e1] ++ sublist 1 (len default_list) default_list)).
      entailer!.
      reflexivity.
      all: try nia;
        unfold default_val;
        simpl;
        try erewrite Zlength_list_repeat;
        try nia; auto.
      all: autorewrite with sublist;
      try erewrite Zlength_sublist_correct;
          try nia;  try setoid_rewrite LB; try nia.
    + forward.
      repeat rewrite_if_b.
      entailer!.
    + break_if.
      assert (buf_size = 0%Z) as S.
      eapply repr_inj_unsigned; strip_repr.
      assert ((30 >=? Int.unsigned (tag >>u Int.repr 2)) = false) as C.
           { erewrite Z.geb_leb.
             Zbool_to_Prop.
             nia. }
      ++ repeat forward.
         forward_loop
      (EX i: Z,
          PROP (i = 1%Z \/ i = 2 \/ i = 3 \/ i = 4 \/ i = 5;
                forall j, 0 <= j < i ->
                     (Int.shru tval (Int.repr j * Int.repr 7) == 0)%int = false)
          LOCAL (temp _tval (Vint (Int.shru tag (Int.repr 2)));
                 temp _i (Vint (Int.repr (i * 7)));
                 temp _required_size (Vint (Int.repr i));
                 temp _size (Vint (Int.repr buf_size));
                 temp _buf__1 (Vptr buf_b buf_ofs))
          SEP (data_at Tsh (tarray tuchar buf_size)
                       (default_val (tarray tuchar buf_size))
                       (Vptr buf_b buf_ofs)))
      break: (let r := required_size (tag >>u(Int.repr 2)) in
              PROP ()
              LOCAL (temp _required_size (Vint (Int.repr r));
                     temp _tval (Vint (tag >>u Int.repr 2));
                     temp _i (Vint (Int.repr (r * 7)));
                     temp _size (Vint (Int.repr buf_size));
                     temp _buf__1 (Vptr buf_b buf_ofs))
                 SEP (data_at Tsh (tarray tuchar buf_size)
                              default_list
                              (Vptr buf_b buf_ofs))).
         * Exists 1%Z.
           entailer!.
           intros.
           replace x with 0%Z by nia.
           erewrite Int.shru_zero.
           destruct  (Int.shru tag (Int.repr 2) == 0) eqn : T.
           eapply int_eq_e in T.
           rewrite T in *.
           cbv in C.
           congruence.
           auto.
         * Intro i.
           forward_if; repeat forward.
           forward_if;
            repeat forward.
           rewrite Int.unsigned_repr in H2.
           entailer!.
           rep_omega.
           Exists (i + 1)%Z.
           rewrite Int.unsigned_repr in H2;
             try rep_omega.
           entailer!.
           split.
        ** intros.
           destruct (zeq j i).
           subst.
           eapply Int.eq_false.
           autorewrite with norm.
           eassumption.
           eapply H4.
           nia.
        ** do 2 f_equal.
           nia.
        ** entailer!.
           assert (required_size (tag >>u (Int.repr 2)) = i) as RS.
           eapply required_size_spec; auto.
           autorewrite with norm.
           eassumption.
           subst.
           intuition.
        ** entailer!.
           rewrite Int.unsigned_repr in H2;
             try rep_omega.
           replace i with 5 in * by nia.
           assert (required_size (tag >>u (Int.repr 2)) = 5) as RS.
           eapply required_size_spec; auto.
           autorewrite with norm.
           cbn.
           erewrite shr_lt_zero_35.
           break_if; auto.
           unfold Int.ltu in Heqb.
           break_if; autorewrite with norm in *.
           replace (Int.unsigned 0) with 0%Z in * by auto with ints.
           nia.
           congruence.
           rewrite RS.
           intuition.
         * (* Post exec rest of the fn *)
           simpl.
           forward_if.
           unfold POSTCONDITION.
           unfold abbreviate.
           try break_let.
           forward.
           unfold tag_serialize in *.
           rewrite C in *.
           repeat rewrite_if_b.
           rewrite Int.unsigned_repr in H2;
            try rep_omega.
           simpl in Heqp.
           replace (-1 <? required_size (tag >>u Int.repr 2)) with true in *
             by (symmetry; Zbool_to_Prop; lia).
           inversion Heqp.
           autorewrite with sublist.
           entailer!.
           generalize H2.
           strip_repr.
           intro. subst. lia.
           subst; strip_repr.
           ++
              assert (buf_size <> 0%Z) as S.
              {  eapply repr_neq_e in n; lia. }
              repeat forward.
         forward_loop (EX i: Z,
          PROP (i = 1%Z \/ i = 2 \/ i = 3 \/ i = 4 \/ i = 5;
                forall j, 0 <= j < i ->
                     (Int.shru tval (Int.repr j * Int.repr 7) == 0)%int = false)
          LOCAL (temp _tval (Vint (tag >>u (Int.repr 2)));
                 temp _i (Vint (Int.repr (i * 7)));
                 temp _required_size (Vint (Int.repr i));
                 temp _size (Vint (Int.repr (buf_size - 1)));
                 temp _buf__1 (offset_val 1 (Vptr buf_b buf_ofs)))
          SEP ((data_at Tsh (tarray tuchar buf_size)
                        (upd_Znth 0 (default_val (tarray tuchar buf_size))
                                  (Vint e1)) (Vptr buf_b buf_ofs))))
      break: (let r := required_size (tag >>u (Int.repr 2)) in
              PROP ()
              LOCAL (temp _required_size (Vint (Int.repr r));
                     temp _tval (Vint (tag >>u Int.repr 2));
                     temp _i (Vint (Int.repr (r * 7)));
                     temp _size (Vint (Int.repr (buf_size - 1)));
                     temp _buf__1 (offset_val 1 (Vptr buf_b buf_ofs)))
                 SEP ((data_at Tsh (tarray tuchar buf_size)
                               (upd_Znth 0 (default_val (tarray tuchar buf_size))
                                         (Vint e1)) (Vptr buf_b buf_ofs)))).
         * Exists 1%Z.
           entailer!.
           intros.
           replace x with 0%Z by nia.
           erewrite Int.shru_zero.
           destruct  (Int.shru tag (Int.repr 2) == 0) eqn : T.
           eapply int_eq_e in T.
           rewrite T in *.
           cbv in H1.
           congruence.
           auto.
         * Intro i.
           forward_if; repeat forward.
           forward_if;
             repeat forward.
           rewrite Int.unsigned_repr in H2.
           entailer!.
           rep_omega.
           Exists (i + 1)%Z.
           rewrite Int.unsigned_repr in H2; try rep_omega.
           entailer!.
           split.
        ** intros.
           destruct (zeq j i).
           subst.
           eapply Int.eq_false.
           autorewrite with norm.
           eassumption.
           eapply H4.
           nia.
        ** do 2 f_equal.
           nia.
        ** entailer!.
           assert (required_size (tag >>u (Int.repr 2)) = i) as RS.
           eapply required_size_spec; auto.
           autorewrite with norm.
           eassumption.
           subst.
           intuition.
        ** entailer!.
           rewrite Int.unsigned_repr in H2; try rep_omega.
           replace i with 5 in * by nia.
           assert (required_size (tag >>u (Int.repr 2)) = 5) as RS.
           eapply required_size_spec; auto.
           autorewrite with norm.
           cbn.
           erewrite shr_lt_zero_35.
           break_if; auto.
           unfold Int.ltu in Heqb.
           break_if; autorewrite with norm in *.
           replace (Int.unsigned 0) with 0%Z in * by auto with ints.
           nia.
           congruence.
           rewrite RS.
           intuition.
         * (* Post exec rest of the fn *)
            assert ((30 >=? Int.unsigned (tag >>u Int.repr 2)) = false) as C.
           { erewrite Z.geb_leb.
             Zbool_to_Prop.
             nia. }
           simpl.
           forward_if.
           unfold POSTCONDITION.
           unfold abbreviate.
           try break_let.
           forward.
           unfold tag_serialize in *.
           rewrite C in *.
           rewrite Int.unsigned_repr in *;
             try rep_omega.
           forward.
           forward.
           normalize.
           strip_repr.
           remember (required_size tval) as r.
           forward_loop (
               EX v : Z, EX ls : list int,
               PROP ((Int.unsigned Int.zero <= v)%Z;
                     (v + 1 <= r)%Z;
                     ls =
                     serialize_tag_loop (r - v - 1)%Z (Z.to_nat v) tval)
               LOCAL (temp _tval (Vint tval);
                      temp _i (Vint (Int.repr ((r * 7) - (v + 1) * 7)%Z));
                      temp _required_size (Vint (Int.repr r));
                      temp _size (Vint (Int.repr (buf_size - 1)));
                      temp _buf__1 (offset_val (v + 1) (Vptr buf_b buf_ofs));
                      temp _end
                      (Vptr buf_b
                            (buf_ofs +
                                    Ptrofs.repr (1 +
                                                 required_size (tag >>u Int.repr 2))
                                    - Ptrofs.repr 1)%ptrofs))
               SEP (data_at Tsh (tarray tuchar 1) [Vint e1] (Vptr buf_b buf_ofs);
                    data_at Tsh (tarray tuchar v) (map Vint ls)
                            (offset_val 1 (Vptr buf_b buf_ofs));
                    data_at Tsh (tarray tuchar (buf_size - v - 1))
                                    (sublist (v + 1) buf_size default_list)
                                    (offset_val (v + 1) (Vptr buf_b buf_ofs))))
          break: (let ls := serialize_tag_loop 0 (Z.to_nat r - 1) tval in
                 PROP ()
                 LOCAL (temp _tval (Vint (tag >>u Int.repr 2));
                        temp _i (Vint 0%int);
                        temp _required_size (Vint (Int.repr r));
                        temp _size (Vint (Int.repr (buf_size - 1)));
                        temp _buf__1 (offset_val r (Vptr buf_b buf_ofs));
                        temp _end
                             (Vptr buf_b
                                   (buf_ofs +
                                    Ptrofs.repr (1 +
                                                 required_size (tag >>u Int.repr 2))
                                    - Ptrofs.repr 1)%ptrofs))

                 SEP (data_at Tsh (tarray tuchar 1) [Vint e1] (Vptr buf_b buf_ofs);
                      data_at Tsh (tarray tuchar (len ls))
                              (map Vint ls)
                              (offset_val 1 (Vptr buf_b buf_ofs));
                      data_at Tsh (tarray tuchar (buf_size - len ls - 1))
                                    (sublist (len ls + 1) buf_size default_list)
                                    (offset_val ((len ls) + 1) (Vptr buf_b buf_ofs)))).
          *** Exists 0%Z.
              Exists (@nil int).
              erewrite data_at_tuchar_zero_array_eq.
              entailer!.
              erewrite <- data_at_app.
              erewrite upd_Znth_unfold.
              erewrite sublist_nil.
              erewrite app_nil_l.
              setoid_rewrite LB.
              replace (1 + (buf_size - 1))%Z with buf_size by nia.
              entailer!.
              all: try setoid_rewrite LB;
                autorewrite with sublist norm; cbn; auto;
                  try rep_omega.
          ***
            Intros v ls.
            forward_if.
           +++
             rewrite Int.unsigned_repr in H2; try rep_omega.
             replace (Int.unsigned 0%int) with 0%Z in * by auto with ints.
             assert (0 <= v + 1 <= (required_size (tag >>u Int.repr 2))) as VR.
             { lia. }
             unfold test_order_ptrs.
             unfold sameblock.
             subst.
             destruct peq; [simpl  |contradiction].
             apply andp_right.
             { apply derives_trans
                 with (Q := valid_pointer
                              (Vptr buf_b (buf_ofs + Ptrofs.repr (v + 1))%ptrofs)).
                entailer!.
               apply valid_pointer_weak. }
             { assert (0 < buf_size - v - 1)%Z as LD by
                     (try erewrite LB; nia).
               assert (sizeof (tarray tuchar (buf_size - v - 1)) > 0) by (simpl; nia).
               remember (default_val (tarray tuchar buf_size)) as default_list.
               remember (required_size (tag >>u Int.repr 2)) as r.
               assert (data_at Tsh (tarray tuchar (buf_size - v - 1))
                               (sublist (v + 1) buf_size (default_val (tarray tuchar buf_size)))
                               (Vptr buf_b (buf_ofs + Ptrofs.repr (v + 1))%ptrofs)
                               |-- weak_valid_pointer
                               (Vptr buf_b
                                     (buf_ofs +  Ptrofs.repr (1 + r) - Ptrofs.repr 1)%ptrofs)).
               { apply derives_trans
                   with (Q := valid_pointer
                                (Vptr buf_b (buf_ofs
                                             + Ptrofs.repr
                                                 (1 + r) - Ptrofs.repr 1)%ptrofs)).
                 assert (sizeof (tarray tuchar (buf_size - v - 1)) > 0) by (simpl; nia).
                 replace (buf_ofs + Ptrofs.repr (1 + r) - Ptrofs.repr 1)%ptrofs
                   with (buf_ofs + Ptrofs.repr r)%ptrofs.
                 Open Scope Z.
                 erewrite data_at_app_gen
                   with (j1 := r - (v + 1))
                        (j2 := len default_list - r)
                        (ls1 := sublist (v + 1) r default_list)
                        (ls2 := sublist r (len default_list) default_list).
                 assert ((buf_ofs + Ptrofs.repr (v + 1) + Ptrofs.repr (r - (v + 1)))%ptrofs =
                         (buf_ofs + Ptrofs.repr r)%ptrofs) as PTR.
                 {  ptrofs_compute_add_mul; try rep_omega.
                    f_equal.
                    rep_omega. }
                 rewrite PTR.
                 assert (sizeof (tarray tuchar (len default_list -  r)) > 0).
                 { simpl.
                   setoid_rewrite LB.
                   nia. }
                 eapply sepcon_valid_pointer2.
                 eapply data_at_valid_ptr; auto.
                 1-5:  replace (Int.unsigned 0%int) with 0%Z in * by auto with ints.
                 4: erewrite sublist_split with (mid := r); subst; auto; try nia.
                 all: try erewrite Zlength_sublist_correct;
                   try nia;  try setoid_rewrite LB; try nia; auto.
                 Focus 3. apply valid_pointer_weak.
                 try erewrite Zlength_sublist_correct;
                   try nia;  try setoid_rewrite LB; ptrofs_compute_add_mul; try rep_omega.
                 erewrite Ptrofs.sub_add_opp.
                 unfold Ptrofs.neg.
                 normalize.
                 f_equal.
                 rewrite Ptrofs.unsigned_repr.
                 f_equal.
                 nia.
                 rep_omega.  }
               entailer!. }
           +++
             Open Scope Z.
             rewrite Int.unsigned_repr in H2; try rep_omega.
             replace (Int.unsigned 0%int) with 0%Z in * by auto with ints.
             eapply typed_true_ptr_lt in H6.
             assert ( Ptrofs.unsigned buf_ofs +  v + 1 <
                      Ptrofs.unsigned buf_ofs + 1 +
                      required_size (tag >>u Int.repr 2) - 1) as PT.
             { generalize H6.
               unfold Ptrofs.sub.
               ptrofs_compute_add_mul.
               all: subst; rep_omega_setup; auto with ints;
                 autorewrite with norm; try rep_omega; try nia. }
             unfold offset_val.
             erewrite split_non_empty_list with
                 (j2 := (len default_list - (v + 1) - 1)%Z)
                 (ls' := (sublist (v + 1 + 1) buf_size default_list))
                 (ls := (sublist (v + 1) buf_size default_list)).
             assert (v < required_size tval)%Z by (subst; lia).
             Intros.
             assert (len default_list - (v + 1) - 1 =
                     len (sublist (v + 1 + 1) (len default_list) default_list)) as LEN.
             { erewrite Zlength_sublist_correct.
               nia.
               rewrite LB.
               all: try nia. }
             forward.
             entailer!.
             unfold Int.iwordsize.
             ints_compute_add_mul.
             cbn - [required_size].
             all: try rep_omega.
             repeat forward.
             remember
               (Int.zero_ext 8
                             (Int.repr 128
                                       or (((tag >>u Int.repr 2) >>u
                                                                 Int.repr ((required_size (tag >>u Int.repr 2) - (len ls)) * 7)) & Int.repr 127))%int)%int
               as e_v.
             Exists (v + 1) (ls ++ [(Int.zero_ext 8
          (Int.repr 128 or ((tval >>u Int.repr (r * 7 - (v + 1) * 7)) & Int.repr 127))%int)]).
             assert (v = len ls) as VLS.
             { subst.
               erewrite loop_len_req_size.
               erewrite Z2Nat_id';
                 erewrite Zmax0r; try nia. }
             entailer!.
             split.
             erewrite Z.add_1_r at 3.
             erewrite Z2Nat.inj_succ.
             simpl. f_equal. rewrite H5 at 1.
             replace (required_size (tag >>u Int.repr 2)  - len ls - 1)
               with (required_size (tag >>u Int.repr 2) - (len ls + 1) - 1 + 1) by list_solve.
             reflexivity.
             admit.
             lia.
             do 2 f_equal. nia.
             replace (required_size (tag >>u Int.repr 2) * 7 - (len ls + 1) * 7)
               with
                 ((required_size (tag >>u Int.repr 2) - (len ls + 1)) * 7) by nia.
             remember
               (Int.zero_ext 8
                             (Int.repr 128
                                       or (((tag >>u Int.repr 2) >>u
                            Int.repr ((required_size (tag >>u Int.repr 2)
                                       - (len ls + 1)) * 7)) &
                                           Int.repr 127))%int)%int
               as e_v.
             unfold offset_val.
             simpl.
             erewrite <- data_at_tuchar_singleton_array_eq.
             remember (default_val (tarray tuchar buf_size)) as default_list.
             replace (buf_ofs + Ptrofs.repr (len ls + 1) + 1)%ptrofs
               with (buf_ofs +  Ptrofs.repr (len ls + 1 + 1))%ptrofs.

             replace (buf_ofs + Ptrofs.repr ((len ls) + 1))%ptrofs
               with (buf_ofs + 1 + Ptrofs.repr (len ls))%ptrofs.
             erewrite <- data_at_app.
             erewrite map_app.
             rewrite <- LB.
             entailer!.
             all: replace (Int.unsigned 0%int) with 0%Z in *
               by (autorewrite with norm; auto);
               autorewrite with list sublist;
               try rep_omega.
             all: ptrofs_compute_add_mul;
               replace (Ptrofs.unsigned 1%ptrofs) with 1 by auto with ptrofs;
               autorewrite with norm;
               try nia; try rep_omega; f_equal; try nia.
             instantiate (1 := Znth (v + 1) default_list).
             erewrite sublist_split with (mid := v + 1 + 1).
             erewrite sublist_len_1.
             reflexivity.
             all: try setoid_rewrite LB; try nia.
             subst. rep_omega.
           +++
             Open Scope Z.
             eapply typed_false_ptr_lt in H6.
             replace (Int.unsigned 0%int) with 0 in * by auto with ints.
             rewrite Int.unsigned_repr in H2; try rep_omega.
             assert ( Ptrofs.unsigned buf_ofs +  v + 1 >=
                      Ptrofs.unsigned buf_ofs + 1 +
                      required_size (tag >>u Int.repr 2) - 1) as PT.
             { generalize H6.
               unfold Ptrofs.sub.
               ptrofs_compute_add_mul.
               all: subst; rep_omega_setup; auto with ints;
                 autorewrite with norm; try rep_omega; try nia. }
             assert (required_size tval < buf_size) by (subst; nia).
             assert (v + 1 >= required_size tval)%Z.
             { subst; lia. }
             assert (v + 1 = r) as V by nia.
             rewrite V.
             forward.
             erewrite <- V in *.
             replace (v + 1 - v - 1) with 0 in *.
             replace (Z.to_nat (v + 1) - 1)%nat with (Z.to_nat v) in *.
             erewrite <- H5.
             entailer!.
             replace 0%int with (Int.repr 0) by auto with ints.
             do 2 f_equal.
             lia.
             erewrite Zlength_map.
             entailer!.
(*             f_equal.
             unfold Ptrofs.sub.
               ptrofs_compute_add_mul;
                 rep_omega_setup; auto with ints;
                 autorewrite with norm; try rep_omega; try nia.
               f_equal.
               lia.
               erewrite Zlength_map.
               entailer!. *)
               replace 1%nat with (Z.to_nat 1) by auto with arith.
               erewrite <- Z2Nat.inj_sub.
               f_equal.
               all: subst; try strip_repr.
             ***
               simpl.
               rewrite Int.unsigned_repr in H2; try rep_omega.
               unfold offset_val.
               remember (serialize_tag_loop 0 (Z.to_nat r - 1) tval) as ls.
               erewrite split_non_empty_list
                 with (ls' := sublist (len ls + 1 + 1) buf_size default_list)
                      (j2 := (buf_size - (len ls + 1 + 1))%Z)
                      (ofs := (buf_ofs + Ptrofs.repr (len ls + 1))%ptrofs).
               Intros.
                assert (r = len ls + 1) as RLS.
             { subst.
               erewrite loop_len_req_size.
               admit. }
               erewrite RLS in *.
               forward.
               unfold POSTCONDITION.
               unfold abbreviate.
               break_let.
               pose proof (req_size_32 tval).
               assert (required_size tval < buf_size) by (subst; lia).
               forward.
               unfold tag_serialize in *.
               rewrite C in *.
               rewrite Int.unsigned_repr in *.
               rewrite_if_b.
                assert ((buf_size - 1 <? required_size (tag >>u Int.repr 2)) = false) as FS.
                { Zbool_to_Prop.
                  nia. }
               rewrite FS in *.
               inversion Heqp.
               unfold offset_val.
               erewrite <- data_at_tuchar_singleton_array_eq.
               erewrite <- data_at_app.
               replace (1 + len ls)%Z with (len ls + 1)%Z by nia.
               erewrite <- data_at_app.
               (* setoid_rewrite <- H6. *)
               remember (Int.zero_ext 8 (((tag & Int.repr 3)
                                            << Int.repr 6) or Int.repr 31)%int) as e0.
               remember (Int.zero_ext 8 ((tag >>u Int.repr 2) & Int.repr 127)%int) as e_n.
               replace (buf_ofs + Ptrofs.repr (len ls + 1) + 1)%ptrofs with
                   (buf_ofs + Ptrofs.repr (len ls + 1 + 1))%ptrofs.
               erewrite <- data_at_app.
               replace (len ls + 1 + 1 + (buf_size - (len ls + 1 + 1))) with buf_size by nia.
               unfold serialize_tag.
               assert ((Z.to_nat (required_size (tag >>u Int.repr 2) - 1)) =
                       (Z.to_nat (len ls + 1) - 1)%nat) as RLS by admit.
               erewrite RLS in *.
               erewrite <- Heqls.
               erewrite <- Heqe_n.
               autorewrite with sublist.
               assert  (([Vint e0] ++ map Vint ls) ++ [Vint e_n] = map Vint (e0 :: ls ++ [e_n]))
                       as V. admit.
               setoid_rewrite V.

               entailer!.
               all: (autorewrite with sublist;
                     try nia; auto).
               all: try erewrite Zlength_sublist_correct;
                 try nia.
               Focus 4.
               instantiate (1 := Znth (len ls + 1) default_list).
               erewrite sublist_split with (mid := len ls + 1 + 1).
               erewrite sublist_len_1.
               reflexivity.
               all: try setoid_rewrite LB; try  rep_omega.
                simpl in H1.
                subst.
                erewrite loop_len_req_size.
                replace 1%nat with (Z.to_nat 1) by auto with arith.
                erewrite <- Z2Nat.inj_sub.
                erewrite Z2Nat_id'.
                erewrite Zmax0r;
                  repeat rep_omega.
                lia.
                subst.
                erewrite loop_len_req_size.
                replace 1%nat with (Z.to_nat 1) by auto with arith.
                erewrite <- Z2Nat.inj_sub.
                erewrite Z2Nat_id'.
                erewrite Zmax0r;
                  repeat rep_omega.
                lia.
                do 2 f_equal.
                all: try lia.
               all: repeat ptrofs_compute_add_mul.
               replace (Ptrofs.unsigned 1%ptrofs) with 1%Z by auto with ptrofs.
               all: rep_omega_setup; auto with ints;
                 autorewrite with norm; try rep_omega; try nia.
               f_equal.
               lia.
               all:  try assert (r = len ls + 1) as RLS by admit; try erewrite <- RLS; try lia.
               subst. lia.
             *** subst. rep_omega.
Admitted.

*)


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*           Layers of PM: Refinement Proof for PQueueIntro            *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between PThreadInit layer and PQueueIntro layer*)
Require Export QueueIntroGenDef.
Require Export QueueIntroGenFresh.
Require Export QueueIntroGenPassthrough.


Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import compcert.common.Values.
Require Import Maps.
Require Import Integers.
Require Import AST.
Require Import Globalenvs.

Require Import Axioms.
Require Import sepcomp.mem_lemmas. (*needed for definition of mem_forward etc*)
Require Import sepcomp.core_semantics.

Require Import sepcomp.StructuredInjections.
Require Import effect_semantics.
Require Import effect_simulations.
Require Import effect_simulations_lemmas.
Require Import sepcomp.forward_simulations_trans.
Require Import Wellfounded.
Require Import Relations.
Require Import effect_corediagram_trans.

Require Import effect_interpolants.
(*Require Import effect_interpolation_proofs. not necessary - interface suffices*)

Declare Module EFFAX : EffectInterpolationAxioms.

Import SM_simulation.

Lemma initial_inject_split: forall j m1 m3 (Inj:Mem.inject j m1 m3),
  exists m2 j1 j2, j = compose_meminj j1 j2 /\
       Mem.inject j1 m1 m2 /\ Mem.inject j2 m2 m3 /\
       (forall b1, (exists b3 d, compose_meminj j1 j2 b1 = Some(b3,d))
                   <-> (exists b2 d1, j1 b1 = Some(b2,d1))) /\
       (forall b2 b3 d2, j2 b2 =Some(b3,d2) ->
                   exists b1 d, compose_meminj j1 j2 b1 = Some(b3,d)) /\
      (forall b1 b2 ofs2, j1 b1 = Some(b2,ofs2) -> (b1=b2 /\ ofs2=0)) /\
      (forall b2 b3 ofs3, j2 b2 = Some (b3, ofs3) ->
               Mem.flat_inj 1%positive b2 = Some (b3, ofs3) \/
               (b2 = Mem.nextblock Mem.empty /\
                    compose_meminj j1 j2 (Mem.nextblock Mem.empty) = Some (b3, ofs3)) \/
               (exists m : positive,
                   b2 = (Mem.nextblock Mem.empty + m)%positive /\
                   compose_meminj j1 j2 (Mem.nextblock Mem.empty + m)%positive =
                   Some (b3, ofs3))).
Proof. intros.
  destruct (EFFAX.interpolate_II_strongHeqMKI _ _ _
     Forward_simulation_trans.empty_inj _ (Forward_simulation_trans.empty_fwd m1) _ _ Forward_simulation_trans.empty_inj _ (Forward_simulation_trans.empty_fwd m3) _ Inj)
  as [m2 [j1 [j2 [J [X [Y [Inc1 [Inc2 [Inj12 [_ [Inj23 AA]]]]]]]]]]].
intros b; intros.
  destruct (compose_meminjD_Some _ _ _ _ _ H) as [? [? [? [? [? ?]]]]].
    subst. destruct (flatinj_E _ _ _ _ H0) as [? [? ?]]. subst.
         exfalso. xomega.
intros b; intros.
   unfold Mem.valid_block; simpl; split; intros N; xomega.
split; intros. unfold Mem.valid_block in H0. simpl in H0. exfalso; xomega.
  apply Mem.perm_valid_block in H0. unfold Mem.valid_block in H0. simpl in H0. exfalso; xomega.
split; intros. unfold Mem.valid_block in H0. simpl in H0. exfalso; xomega.
  apply Mem.perm_valid_block in H0. unfold Mem.valid_block in H0. simpl in H0. exfalso; xomega.
subst. exists m2, j1, j2.
split; trivial.
split; trivial.
split; trivial.
destruct AA as [_ [_ [_ [_ [_ [XX YY]]]]]].
split. intros.
  split; intros. destruct H as [b3 [d COMP]].
    destruct (compose_meminjD_Some _ _ _ _ _ COMP) as
        [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear COMP.
    exists b2, d1; trivial.
  intros. destruct H as [b2 [d1 J1]].
    destruct (X _ _ _ J1) as [FL | COMP]; trivial.
    destruct (flatinj_E _ _ _ _ FL) as [? [? ?]].
      subst. clear -H1. exfalso. xomega.
split. intros.
    destruct (Y _ _ _ H) as [FL | COMP]; trivial.
    destruct (flatinj_E _ _ _ _ FL) as [? [? ?]].
      subst. clear -H2. exfalso. xomega.
split. intros.
  destruct (XX _ _ _ H) as [AA | [AA | AA]].
    apply flatinj_E in AA.
      destruct AA as [? [? ?]]; subst. intuition.
    destruct AA as [? [? ?]]; subst. intuition.
    destruct AA as [mm [[? ?] ?]]; subst. intuition.
apply YY.
Qed.
(*
Lemma initial_inject_split: forall j m1 m3 (Inj:Mem.inject j m1 m3),
  exists m2 j1 j2, j = compose_meminj j1 j2 /\
       Mem.inject j1 m1 m2 /\ Mem.inject j2 m2 m3 /\
       (forall b1, (exists b3 d, compose_meminj j1 j2 b1 = Some(b3,d))
                   <-> (exists b2 d1, j1 b1 = Some(b2,d1))) /\
       (forall b2 b3 d2, j2 b2 =Some(b3,d2) ->
                   exists b1 d, compose_meminj j1 j2 b1 = Some(b3,d)) /\
      (forall b1 b2 ofs2, j1 b1 = Some(b2,ofs2) -> (b1=b2 /\ ofs2=0)) /\
      (forall b2 b3 ofs3, j2 b2 = Some (b3, ofs3) ->
               Mem.flat_inj 1%positive b2 = Some (b3, ofs3) \/
               (b2 = Mem.nextblock Mem.empty /\
                    compose_meminj j1 j2 (Mem.nextblock Mem.empty) = Some (b3, ofs3)) \/
               (exists m : positive,
                   b2 = (Mem.nextblock Mem.empty + m)%positive /\
                   compose_meminj j1 j2 (Mem.nextblock Mem.empty + m)%positive =
                   Some (b3, ofs3))) /\
      (forall b1 b2 ofs2, j1 b1 = Some(b2,ofs2) -> (b1=b2 /\ ofs2=0)) /\
      (forall b2 b3 ofs3, j2 b2 = Some (b3, ofs3) ->
              Mem.flat_inj 1%positive b2 = Some (b3, ofs3) \/
              (b2 = Mem.nextblock Mem.empty /\
                compose_meminj j1 j2 (Mem.nextblock Mem.empty) = Some (b3, ofs3)) \/
              (exists m : positive,
                b2 = (Mem.nextblock Mem.empty + m)%positive /\
                compose_meminj j1 j2 (Mem.nextblock Mem.empty + m)%positive =
                Some (b3, ofs3))).
Proof. intros.
  destruct (EFFAX.interpolate_II_strong _ _ _ Forward_simulation_trans.empty_inj _ (Forward_simulation_trans.empty_fwd m1) _ _ Forward_simulation_trans.empty_inj _ (Forward_simulation_trans.empty_fwd m3) _ Inj)
  as [m2 [j1 [j2 [J [X [Y [Inc1 [Inc2 [Inj12 [_ [Inj23 _]]]]]]]]]]].
intros b; intros.
  destruct (compose_meminjD_Some _ _ _ _ _ H) as [? [? [? [? [? ?]]]]].
    subst. destruct (flatinj_E _ _ _ _ H0) as [? [? ?]]. subst.
         exfalso. xomega.
intros b; intros.
   unfold Mem.valid_block; simpl; split; intros N; xomega.
split; intros. unfold Mem.valid_block in H0. simpl in H0. exfalso; xomega.
  apply Mem.perm_valid_block in H0. unfold Mem.valid_block in H0. simpl in H0. exfalso; xomega.
split; intros. unfold Mem.valid_block in H0. simpl in H0. exfalso; xomega.
  apply Mem.perm_valid_block in H0. unfold Mem.valid_block in H0. simpl in H0. exfalso; xomega.
subst. exists m2, j1, j2.
split; trivial.
split; trivial.
split; trivial.
split. intros.
  split; intros. destruct H as [b3 [d COMP]].
    destruct (compose_meminjD_Some _ _ _ _ _ COMP) as
        [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear COMP.
    exists b2, d1; trivial.
  intros. destruct H as [b2 [d1 J1]].
    destruct (X _ _ _ J1) as [FL | COMP]; trivial.
    destruct (flatinj_E _ _ _ _ FL) as [? [? ?]].
      subst. clear -H1. exfalso. xomega.
split. intros.
    destruct (Y _ _ _ H) as [FL | COMP]; trivial.
    destruct (flatinj_E _ _ _ _ FL) as [? [? ?]].
      subst. clear -H2. exfalso. xomega.
split; intros.
  destruct (X _ _ _ H) as [AA | AA].
    apply flatinj_E in AA.
      destruct AA as [? [? ?]]; subst. intuition.

Qed.
*)

Section Eff_sim_trans.
Context {F1 V1 C1 F2 V2 C2 F3 V3 C3:Type}
        (Sem1 : @EffectSem (Genv.t F1 V1) C1)
        (Sem2 : @EffectSem (Genv.t F2 V2) C2)
        (Sem3 : @EffectSem (Genv.t F3 V3) C3)
        (g1 : Genv.t F1 V1)
        (g2 : Genv.t F2 V2)
        (g3 : Genv.t F3 V3)
        epts12 epts23 epts13
        (EPC : entrypoints_compose epts12 epts23 epts13).

Theorem eff_sim_trans: forall
        (SIM12: @SM_simulation_inject _ _ _ _ _ _ Sem1 Sem2 g1 g2 epts12)
        (SIM23: @SM_simulation_inject _ _ _ _ _ _ Sem2 Sem3 g2 g3 epts23),
        @SM_simulation_inject _ _ _ _ _ _ Sem1 Sem3 g1 g3 epts13.
Proof. (*follows structure of forward_simulations_trans.injinj*)
  intros.
  destruct SIM12
    as [core_data12 match_core12 core_ord12 core_ord_wf12
      match_sm_wd12 genvs_dom_eq12 match_genv12
      match_visible12 match_restrict12
      match_sm_valid12 (*match_protected12*) core_initial12
      core_diagram12 effcore_diagram12
      core_halted12 core_at_external12 eff_after_external12].
  destruct SIM23
    as [core_data23 match_core23 core_ord23 core_ord_wf23
      match_sm_wd23 genvs_dom_eq23 match_genv23
      match_visible23 match_restrict23
      match_sm_valid23 (*match_protected23*) core_initial23
      core_diagram23 effcore_diagram23
      core_halted23 core_at_external23 eff_after_external23].
  eapply Build_SM_simulation_inject with
    (core_ord := clos_trans _ (sem_compose_ord_eq_eq core_ord12 core_ord23 C2))
    (match_state := fun d mu c1 m1 c3 m3 =>
      match d with (d1,X,d2) =>
        exists c2, exists m2, exists mu1, exists mu2,
          X=Some c2 /\ mu = compose_sm mu1 mu2 /\
          (locBlocksTgt mu1 = locBlocksSrc mu2 /\
           extBlocksTgt mu1 = extBlocksSrc mu2 /\
           (forall b, pubBlocksTgt mu1 b = true -> pubBlocksSrc mu2 b = true) /\
           (forall b, frgnBlocksTgt mu1 b = true -> frgnBlocksSrc mu2 b = true)) /\
          match_core12 d1 mu1 c1 m1 c2 m2 /\ match_core23 d2 mu2 c2 m2 c3 m3
      end).
 (*well_founded*)
  eapply wf_clos_trans. eapply well_founded_sem_compose_ord_eq_eq; assumption.
 (*match_sm_wd*) clear - match_sm_wd12 match_sm_wd23.
  intros. rename c2 into c3. rename m2 into m3.
  destruct d as [[d12 cc2] d23].
  destruct H as [c2 [m2 [mu12 [mu23 [X [J [INV [MC12 MC23]]]]]]]]; subst.
  specialize (match_sm_wd12 _ _ _ _ _ _ MC12).
  specialize (match_sm_wd23 _ _ _ _ _ _ MC23).
  destruct INV as [INVa [INVb [INVc INVd]]].
  eapply (compose_sm_wd); eauto.
 (*genvs_domain_eq*)
  eapply genvs_domain_eq_trans; eassumption.
 (*match_genv for definition using
       meminj_preserves_globals ge1 (foreign_of mu)
  clear - genvs_dom_eq12 match_sm_wd12 match_genv12 match_genv23.
  intros. rename c2 into c3. rename m2 into m3.
  destruct d as [[d12 cc2] d23].
  destruct H as [c2 [m2 [mu12 [mu23 [X [J [INV [MC12 MC23]]]]]]]]; subst.
  specialize (match_genv12 _ _ _ _ _ _ MC12).
  specialize (match_genv23 _ _ _ _ _ _ MC23).
  apply meminj_preserves_genv2blocks.
  apply meminj_preserves_genv2blocks in match_genv12.
  apply meminj_preserves_genv2blocks in match_genv23.
  rewrite compose_sm_foreign.
    solve [eapply meminj_preserves_globals_ind_compose; eassumption].
    eapply INV.
    eauto.*)
 (*match_genv*)
  clear - genvs_dom_eq12 match_sm_wd12 match_genv12 match_genv23.
  intros. rename c2 into c3. rename m2 into m3.
  destruct d as [[d12 cc2] d23].
  destruct MC as [c2 [m2 [mu12 [mu23 [X [J [INV [MC12 MC23]]]]]]]]; subst.
  destruct (match_genv12 _ _ _ _ _ _ MC12) as [GE12a GE12b].
  destruct (match_genv23 _ _ _ _ _ _ MC23) as [GE23a GE23b].
  split. apply meminj_preserves_genv2blocks.
         apply meminj_preserves_genv2blocks in GE12a.
         apply meminj_preserves_genv2blocks in GE23a.
         rewrite compose_sm_extern.
         solve [eapply meminj_preserves_globals_ind_compose; eassumption].
  apply GE12b.
 (*match_visible*)
    clear - match_sm_wd12 match_visible12.
    intros. rename c2 into c3. rename m2 into m3.
      destruct d as [[d12 cc2] d23].
      destruct H as [c2 [m2 [mu12 [mu23 [X [J [INV [MC12 MC23]]]]]]]]; subst.
      simpl. rewrite vis_compose_sm. eapply match_visible12. eassumption.
 (*match_restrict*)
    clear - match_restrict12.
    intros. rename c2 into c3. rename m2 into m3.
    destruct d as [[d12 cc2] d23].
    destruct H as [c2 [m2 [mu12 [mu23 [XX [J [INV [MC12 MC23]]]]]]]]; subst.
    simpl in *.
    exists c2, m2, (restrict_sm mu12 X), mu23.
    specialize (match_restrict12 _ _ _ _ _ _ X MC12 H0 H1).
    intuition.
    unfold compose_sm; simpl.
    f_equal; try (destruct mu12; reflexivity).
      destruct mu12; simpl in *.
        unfold compose_meminj, restrict. extensionality b.
        remember (X b) as d.
        destruct d; trivial.
      destruct mu12; simpl in *.
        unfold compose_meminj, restrict. extensionality b.
        remember (X b) as d.
        destruct d; trivial.
      destruct mu12; simpl in *. assumption.
      destruct mu12; simpl in *. assumption.
      destruct mu12; simpl in *. apply (H2 _ H4).
      destruct mu12; simpl in *. apply (H5 _ H4).
 (*sm_valid*)
    clear - match_sm_valid12 match_sm_valid23.
    intros. rename c2 into c3.  rename m2 into m3.
    destruct d as [[d12 cc2] d23].
    destruct H as [c2 [m2 [mu12 [mu23 [X [J [INV [MC12 MC23]]]]]]]]; subst.
    specialize (match_sm_valid12 _ _ _ _ _ _ MC12).
    specialize (match_sm_valid23 _ _ _ _ _ _ MC23).
    unfold sm_valid, compose_sm. destruct mu12; destruct mu23; simpl in *.
    split; intros. eapply match_sm_valid12. apply H.
    eapply match_sm_valid23. apply H.
 (*match_protected
    clear - match_sm_wd12 match_protected12
            match_sm_wd23 match_protected23.
    intros. rename c2 into c3.  rename m2 into m3.
    destruct d as [[d12 cc2] d23].
    destruct H as [c2 [m2 [mu12 [mu23 [X [J [INV [MC12 MC23]]]]]]]]; subst.
    simpl. apply (match_protected12 _ _ _ _ _ _ MC12 _ H0 H1).*)
 (*initial_core*)
   (*version where envirnment delivers structured injection:
     to complete this proof, we'd have to replace the call to
     initial_inject_split 3 line down to one to variant that merges
     the results of the two lemmas in effect_interpolants, namely
     effect_interp_II and interpolate_II_strongHeqMKI. That should be possible
     but is left as future work.
   clear - EPC genvs_dom_eq12 core_initial12 genvs_dom_eq23 core_initial23.
   intros. rename m2 into m3. rename v2 into v3. rename vals2 into vals3.
    rewrite (EPC v1 v3 sig) in H. destruct H as [v2 [EP12 EP23]].
    (*assert (HT: Forall2 Val.has_type vals1 (sig_args sig)).
      eapply forall_valinject_hastype; eassumption.*)
    destruct (initial_inject_split _ _ _ H1)
       as [m2 [j1 [j2 [J [Inj12 [Inj23 [X [Y [XX YY]]]]]]]]].
    subst. rewrite J in *.
    destruct (Forward_simulation_trans.forall_val_inject_split _ _ _ _ H2)
       as [vals2 [ValsInj12 ValsInj23]].
    assert (PG1: meminj_preserves_globals g1 j1).
      clear - X Y XX YY H3 H4.
      apply meminj_preserves_genv2blocks.
      apply meminj_preserves_genv2blocks in H3.
      destruct H3 as [AA [BB CC]].
      split; intros.
         specialize (AA _ H).
         destruct (compose_meminjD_Some _ _ _ _ _ AA)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear AA.
         destruct (XX _ _ _ J1); subst. trivial.
      split; intros.
         specialize (BB _ H).
         destruct (compose_meminjD_Some _ _ _ _ _ BB)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear BB.
         destruct (XX _ _ _ J1); subst. trivial.
      destruct (XX _ _ _ H0); subst. trivial.
  assert (PG2: meminj_preserves_globals g2 j2).
    clear - XX YY X Y PG1 H3 genvs_dom_eq12.
    apply meminj_preserves_genv2blocks.
     apply meminj_preserves_genv2blocks in H3.
      destruct H3 as [AA [BB CC]].
     apply meminj_preserves_genv2blocks in PG1.
      destruct PG1 as [AA1 [BB1 CC1]].
      destruct genvs_dom_eq12.
      split; intros.
         apply H in H1.
         specialize (AA1 _ H1). specialize (AA _ H1).
         destruct (compose_meminjD_Some _ _ _ _ _ AA)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear AA.
         rewrite J1 in AA1. inv AA1. simpl in D. subst. trivial.
      split; intros.
         apply H0 in H1.
         specialize (BB1 _ H1). specialize (BB _ H1).
         destruct (compose_meminjD_Some _ _ _ _ _ BB)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear BB.
         rewrite J1 in BB1. inv BB1. simpl in D. subst. trivial.
      apply H0 in H1.
         specialize (BB1 _ H1). specialize (BB _ H1). rename b2 into b3.
         destruct (compose_meminjD_Some _ _ _ _ _ BB)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear BB.
         destruct (XX _ _ _ J1); subst. simpl in D. subst.
         clear BB1 XX.
         destruct (YY _ _ _ H2) as [XX | [XX | XX]].
           apply flatinj_E in XX. destruct XX as [? [? ?]]; subst. trivial.
           destruct XX as [? ?]; subst.
             apply (CC _ _ _ H1 H4).
           destruct XX as [mm [? ?]]; subst.
             apply (CC _ _ _ H1 H4).
     exploit (core_initial12 _ _ _ EP12 vals1 _ _ _ vals2 _ H0 Inj12). with (vals2:=vals3); try eassumption.
         rewrite J. eassumption.
         rewrite J. eassumption.
         rewrite J. eassumption.
         (*eapply forall_valinject_hastype; eassumption.*)
         intros. eapply H6.
              rewrite (genvs_domain_eq_isGlobal _ _ genvs_dom_eq23) in H.
              assumption.
       intros [d12 [c2 [Ini2 MC12]]].
     exploit (core_initial23 _ _ _ EP23 vals2); try eassumption.
         rewrite J. eassumption.
         rewrite J. eassumption.
         rewrite J. eassumption.
         (*eapply forall_valinject_hastype; eassumption.*)
         intros. eapply H6.
              rewrite (genvs_domain_eq_isGlobal _ _ genvs_dom_eq23) in H.
              assumption.

        assert (Q: forall b,  isGlobalBlock g2 b || getBlocks vals2 b = true ->
                   exists jb d, j2 b = Some (jb, d) /\
                           isGlobalBlock g3 jb || getBlocks vals3 jb = true).
          intros b' Hb'. apply orb_true_iff in Hb'.
          destruct Hb' as [Hb' | Hb'].
            rewrite (meminj_preserves_globals_isGlobalBlock _ _ PG2 _ Hb').
              exists b', 0.
              rewrite (genvs_domain_eq_isGlobal _ _ genvs_dom_eq23) in Hb'.
              rewrite Hb'. intuition.
          destruct (getBlocks_inject _ _ _  ValsInj23 _ Hb') as [bb [ofs [J2 GB2]]].
              exists bb, ofs. intuition.
        specialize (REACH_inject _ _ _ Inj23
            (fun b' : block => isGlobalBlock g2 b' || getBlocks vals2 b')
            (fun b' : block => isGlobalBlock g3 b' || getBlocks vals3 b')
            Q). intros. as [b3 [d2 [J2 R3]]].
        rewrite J2.
        destruct (Y _ _ _ J2) as [b1 [d COMP]].
        apply (H4 _ _ _ COMP).
      intros b2 Hb2. remember (j2 b2) as d.
        destruct d; inv Hb2; apply eq_sym in Heqd. destruct p.
        eapply Mem.valid_block_inject_1; eassumption.
      (*eapply forall_valinject_hastype; eassumption.*)
      intros. destruct (X b1) as [_ J1Comp].
              destruct J1Comp as [b3 [dd COMP]]. exists b2, d; trivial.
              specialize (H4 _ _ _ COMP).
              destruct (compose_meminjD_Some _ _ _ _ _ COMP)
                as [bb2 [dd1 [dd2 [J1 [J2 D]]]]]; subst; clear COMP.
              rewrite J1 in H; inv H. rewrite J2. apply H4.
      intros.*)
 (*initial_core*)
   clear - EPC genvs_dom_eq12 core_initial12 genvs_dom_eq23 core_initial23.
   intros. rename m2 into m3. rename v2 into v3. rename vals2 into vals3.
    rewrite (EPC v1 v3 sig) in H. destruct H as [v2 [EP12 EP23]].
    (*assert (HT: Forall2 Val.has_type vals1 (sig_args sig)).
      eapply forall_valinject_hastype; eassumption.*)
    destruct (initial_inject_split _ _ _ H1)
       as [m2 [j1 [j2 [J [Inj12 [Inj23 [X [Y [XX YY]]]]]]]]].
    subst.
    destruct (Forward_simulation_trans.forall_val_inject_split _ _ _ _ H2)
       as [vals2 [ValsInj12 ValsInj23]].
    assert (PG1: meminj_preserves_globals g1 j1).
      clear - X Y XX YY H3 H4.
      apply meminj_preserves_genv2blocks.
      apply meminj_preserves_genv2blocks in H3.
      destruct H3 as [AA [BB CC]].
      split; intros.
         specialize (AA _ H).
         destruct (compose_meminjD_Some _ _ _ _ _ AA)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear AA.
         destruct (XX _ _ _ J1); subst. trivial.
      split; intros.
         specialize (BB _ H).
         destruct (compose_meminjD_Some _ _ _ _ _ BB)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear BB.
         destruct (XX _ _ _ J1); subst. trivial.
      destruct (XX _ _ _ H0); subst. trivial.
  assert (PG2: meminj_preserves_globals g2 j2).
    clear - XX YY X Y PG1 H3 genvs_dom_eq12.
    apply meminj_preserves_genv2blocks.
     apply meminj_preserves_genv2blocks in H3.
      destruct H3 as [AA [BB CC]].
     apply meminj_preserves_genv2blocks in PG1.
      destruct PG1 as [AA1 [BB1 CC1]].
      destruct genvs_dom_eq12.
      split; intros.
         apply H in H1.
         specialize (AA1 _ H1). specialize (AA _ H1).
         destruct (compose_meminjD_Some _ _ _ _ _ AA)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear AA.
         rewrite J1 in AA1. inv AA1. simpl in D. subst. trivial.
      split; intros.
         apply H0 in H1.
         specialize (BB1 _ H1). specialize (BB _ H1).
         destruct (compose_meminjD_Some _ _ _ _ _ BB)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear BB.
         rewrite J1 in BB1. inv BB1. simpl in D. subst. trivial.
      apply H0 in H1.
         specialize (BB1 _ H1). specialize (BB _ H1). rename b2 into b3.
         destruct (compose_meminjD_Some _ _ _ _ _ BB)
            as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear BB.
         destruct (XX _ _ _ J1); subst. simpl in D. subst.
         clear BB1 XX.
         destruct (YY _ _ _ H2) as [XX | [XX | XX]].
           apply flatinj_E in XX. destruct XX as [? [? ?]]; subst. trivial.
           destruct XX as [? ?]; subst.
             apply (CC _ _ _ H1 H4).
           destruct XX as [mm [? ?]]; subst.
             apply (CC _ _ _ H1 H4).
    destruct (core_initial12 _ _ _ EP12 _ _ _ _ vals2 _
       DomS (fun b => match j2 b with None => false | Some (b3,d) => DomT b3 end) H0 Inj12)
     as [d12 [c2 [Ini2 MC12]]]; try assumption.
      (*eapply forall_valinject_hastype; eassumption.*)
      intros. destruct (X b1) as [_ J1Comp].
              destruct J1Comp as [b3 [dd COMP]]. exists b2, d; trivial.
              specialize (H4 _ _ _ COMP).
              destruct (compose_meminjD_Some _ _ _ _ _ COMP)
                as [bb2 [dd1 [dd2 [J1 [J2 D]]]]]; subst; clear COMP.
              rewrite J1 in H; inv H. rewrite J2. apply H4.
      intros.
        assert (Q: forall b,  isGlobalBlock g2 b || getBlocks vals2 b = true ->
                   exists jb d, j2 b = Some (jb, d) /\
                           isGlobalBlock g3 jb || getBlocks vals3 jb = true).
          intros b' Hb'. apply orb_true_iff in Hb'.
          destruct Hb' as [Hb' | Hb'].
            rewrite (meminj_preserves_globals_isGlobalBlock _ _ PG2 _ Hb').
              exists b', 0.
              rewrite (genvs_domain_eq_isGlobal _ _ genvs_dom_eq23) in Hb'.
              rewrite Hb'. intuition.
          destruct (getBlocks_inject _ _ _  ValsInj23 _ Hb') as [bb [ofs [J2 GB2]]].
              exists bb, ofs. intuition.
        destruct (REACH_inject _ _ _ Inj23
            (fun b' : block => isGlobalBlock g2 b' || getBlocks vals2 b')
            (fun b' : block => isGlobalBlock g3 b' || getBlocks vals3 b')
            Q _ H) as [b3 [d2 [J2 R3]]].
        rewrite J2.
        destruct (Y _ _ _ J2) as [b1 [d COMP]].
        apply (H4 _ _ _ COMP).
      intros b2 Hb2. remember (j2 b2) as d.
        destruct d; inv Hb2; apply eq_sym in Heqd. destruct p.
        eapply Mem.valid_block_inject_1; eassumption.
    destruct (core_initial23 _ _ _ EP23 _ _ _ _ vals3 _
       (fun b => match j2 b with None => false | Some (b3,d) => DomT b3 end) DomT Ini2 Inj23)
     as [d23 [c3 [Ini3 MC23]]]; try assumption.
       intros b2 b3 d2 J2. rewrite J2.
         destruct (Y _ _ _ J2) as [b1 [d COMP]].
         destruct (H4 _ _ _ COMP). split; trivial.
    intros b2 Hb2. remember (j2 b2) as d.
        destruct d; inv Hb2; apply eq_sym in Heqd. destruct p.
        eapply Mem.valid_block_inject_1; eassumption.
    remember (initial_SM DomS
            (fun b : block =>
             match j2 b with
             | Some (b3, _) => DomT b3
             | None => false
             end) (REACH m1 (fun b => isGlobalBlock g1 b || getBlocks vals1 b))
                  (REACH m2 (fun b => isGlobalBlock g2 b || getBlocks vals2 b))
            j1) as mu1.
  remember (initial_SM
            (fun b : block =>
             match j2 b with
             | Some (b3, _) => DomT b3
             | None => false
             end) DomT (REACH m2 (fun b => isGlobalBlock g2 b || getBlocks vals2 b))
                       (REACH m3 (fun b => isGlobalBlock g3 b || getBlocks vals3 b))
             j2) as mu2.
  exists (d12,Some c2,d23).
  exists c3.
  split; trivial.
  exists c2, m2, mu1, mu2.
  split; trivial.
  split. subst. unfold initial_SM, compose_sm; simpl.
           f_equal.
  split. subst; simpl. repeat (split; trivial).
  split; trivial.
 (*core_diagram*)
  clear - match_sm_wd12 match_sm_valid12 core_diagram12
          match_sm_wd23 match_sm_valid23 core_diagram23.
  intros. rename st2 into st3. rename m2 into m3.
  destruct cd as [[d12 cc2] d23].
  destruct H0 as [c2 [m2 [mu12 [mu23 [X [J [INV [MC12 MC23]]]]]]]]; subst.
  eapply core_diagram_trans; try eassumption.
 (*effcore_diagram*)
  clear - match_sm_wd12 match_sm_valid12 effcore_diagram12
          match_sm_wd23 match_sm_valid23 effcore_diagram23.
  intros. rename st2 into st3. rename m2 into m3.
  destruct cd as [[d12 cc2] d23].
  destruct H0 as [c2 [m2 [mu12 [mu23 [X [J [INV [MC12 MC23]]]]]]]]; subst.
  eapply effcore_diagram_trans; eassumption.
(*halted*)
  clear - match_sm_wd12 core_halted12 match_sm_wd23 core_halted23.
  intros. rename c2 into c3. rename m2 into m3.
  destruct cd as [[d12 cc2] d23].
  destruct H as [c2 [m2 [mu12 [mu23 [X [J [INV [MC12 MC23]]]]]]]]; subst.
  destruct (core_halted12 _ _ _ _ _ _ _ MC12 H0) as
     [v2 [MInj12 [RValsInject12 HaltedMid]]].
  destruct (core_halted23 _ _ _ _ _ _ _ MC23 HaltedMid) as
     [v3 [MInj23 [RValsInject23 HaltedTgt]]].
  exists v3.
  assert (WDmu12:= match_sm_wd12 _ _ _ _ _ _ MC12).
  assert (WDmu23:= match_sm_wd23 _ _ _ _ _ _ MC23).
  destruct INV as [INVa [INVb [INVc INVd]]].

  split. rewrite compose_sm_as_inj; trivial.
           eapply Mem.inject_compose; eassumption.
  split. rewrite compose_sm_as_inj; trivial.
         rewrite restrict_compose, vis_compose_sm; simpl.
         eapply val_inject_compose; try eassumption.
         eapply val_inject_incr; try eassumption.
         apply restrict_incr.
  assumption.
(*at_external*)
  clear - match_sm_wd12 core_at_external12 match_sm_wd23 core_at_external23.
  intros. rename c2 into c3. rename m2 into m3.
  rename H0 into AtExtSrc.
  destruct cd as [[d12 cc2] d23].
  destruct H as [st2 [m2 [mu12 [mu23 [Hst2 [HMu [GLUEINV [MC12 MC23]]]]]]]].
  subst.
  destruct (core_at_external12 _ _ _ _ _ _ _ _ _ MC12 AtExtSrc)
    as [MInj12 [vals2 [ArgsInj12 (*[ArgsHT2*) AtExt2(*]*)]]]; clear core_at_external12.
  destruct (core_at_external23 _ _ _ _ _ _ _ _ _ MC23 AtExt2)
    as [MInj23 [vals3 [ArgsInj23 (*[ArgsHTTgt*) AtExtTgt(*]*)]]]; clear core_at_external23.
  rewrite compose_sm_as_inj; try eauto.
    split. eapply Mem.inject_compose; eassumption.
    exists vals3.
    split. rewrite restrict_compose, vis_compose_sm; simpl.
           eapply forall_val_inject_compose; try eassumption.
           eapply forall_vals_inject_restrictD; eassumption.
    (*split;*) assumption.
  eapply GLUEINV.
  eapply GLUEINV.
(*after_external*)
  clear - match_sm_wd12 match_sm_valid12 core_at_external12 eff_after_external12
          match_visible12 match_restrict12
          match_sm_wd23 match_sm_valid23 core_at_external23 eff_after_external23.
  intros. rename st2 into st3. rename m2 into m3.
          rename vals2 into vals3'. rename m2' into m3'.
          rename UnchLOOR into UnchLOOR13.
  destruct cd as [[d12 cc2] d23].
  destruct MatchMu as [st2 [m2 [mu12 [mu23 [Hst2 [HMu [GLUEINV [MC12 MC23]]]]]]]].
  assert (WDmu12:= match_sm_wd12 _ _ _ _ _ _ MC12).
  assert (WDmu23:= match_sm_wd23 _ _ _ _ _ _ MC23).
  remember (fun b => locBlocksSrc mu12 b || frgnBlocksSrc mu12 b || mapped (as_inj (compose_sm mu12 mu23)) b)
      as RESTR.
  assert (NormMC12: match_core12 d12 (restrict_sm mu12 RESTR) st1 m1 st2 m2).
     apply match_restrict12. apply MC12.
     subst RESTR. clear. intuition.
     subst RESTR.
     clear UnchLOOR13 UnchPrivSrc Mu'Hyp mu' frgnTgtHyp frgnTgt'
              frgnSrcHyp frgnSrc' FwdTgt FwdSrc RValInjNu' MemInjNu'
              SMvalNu' WDnu' SEP INC m3' ret2 m1' ret1 nu' NuHyp nu
              pubTgtHyp pubTgt' pubSrcHyp pubSrc' ValInjMu AtExtTgt
              AtExtSrc eff_after_external23 core_at_external23
              eff_after_external12 core_at_external12.
     subst. intros b Hb. rewrite REACHAX in Hb.
      destruct Hb as [L HL].
      generalize dependent b.
      induction L; simpl; intros; inv HL.
        apply H.
      specialize (IHL _ H1); clear H1.
        apply orb_true_iff in IHL. apply orb_true_iff.
        destruct IHL.
          left. eapply (match_visible12 _ _ _ _ _ _ MC12).
                eapply REACH_cons; try eassumption.
                apply REACH_nil. apply H.
          right. eapply (inject_REACH_closed _ _ _ MemInjMu).
                eapply REACH_cons; try eassumption.
                apply REACH_nil. apply H.
  remember (restrict_sm mu12 RESTR) as nmu12.
  assert (HmuNorm: mu = compose_sm nmu12 mu23).
     clear UnchLOOR13 UnchPrivSrc Mu'Hyp mu' frgnTgtHyp frgnTgt'
              frgnSrcHyp frgnSrc' FwdTgt FwdSrc RValInjNu' MemInjNu'
              SMvalNu' WDnu' SEP INC m3' ret2 m1' ret1 nu' NuHyp nu
              pubTgtHyp pubTgt' pubSrcHyp pubSrc' ValInjMu AtExtTgt
              AtExtSrc eff_after_external23 core_at_external23
              eff_after_external12 core_at_external12.
      subst nmu12 mu RESTR. unfold compose_sm; simpl.
          rewrite restrict_sm_extern.
          rewrite (restrict_sm_local' _ WDmu12).
          Focus 2. clear. intuition.
          unfold restrict_sm; simpl.
          destruct mu12; simpl in *.
          f_equal.
          extensionality b. unfold compose_meminj, restrict, mapped, as_inj, join; simpl.
          remember (extern_of b) as d.
          specialize (disjoint_extern_local _ WDmu12 b); simpl; intros DD.
          destruct d; trivial; apply eq_sym in Heqd.
            destruct p as [b2 d1].
            destruct DD; try congruence.
            rewrite H.
            destruct (extern_DomRng _ WDmu12 _ _ _ Heqd); simpl in *.
            assert (EE:= extBlocksSrc_locBlocksSrc _ WDmu12 _ H0); simpl in *.
            rewrite EE; simpl.
            remember (frgnBlocksSrc b) as q.
            destruct q; apply eq_sym in Heqq; simpl in *. reflexivity.
            remember (StructuredInjections.extern_of mu23 b2) as w.
            destruct w; trivial. destruct p. rewrite <- Heqw. trivial.
         remember (locBlocksSrc b) as q.
         destruct q; simpl; trivial.
         remember (frgnBlocksSrc b) as w.
         destruct w; trivial; simpl; apply eq_sym in Heqw.
         remember (local_of b) as t.
         destruct t; simpl; trivial.
         destruct p; apply eq_sym in Heqt.
         destruct (local_DomRng _ WDmu12 _ _ _ Heqt); simpl in *. congruence.
  clear MC12.
  assert (WDnmu12:= match_sm_wd12 _ _ _ _ _ _ NormMC12).
  clear HMu.
  assert (WDmu: SM_wd (compose_sm nmu12 mu23)).
    eapply compose_sm_wd; try eassumption.
      subst. unfold restrict_sm, restrict; simpl. destruct mu12; simpl in *. apply GLUEINV.
      subst. unfold restrict_sm, restrict; simpl. destruct mu12; simpl in *. apply GLUEINV.
  clear match_restrict12 match_visible12.
  assert (mu12_valid:= match_sm_valid12 _ _ _ _ _ _ NormMC12).
  assert (mu23_valid:= match_sm_valid23 _ _ _ _ _ _ MC23).
  rename ret2 into ret3.
  destruct (core_at_external12 _ _ _ _ _ _ _ _ _ NormMC12 AtExtSrc)
   as [MInj12 [vals2 [ArgsInj12 (*[ArgsHT2*) AtExt2(*]*)]]]; clear core_at_external12.
  destruct (core_at_external23 _ _ _ _ _ _ _ _ _ MC23 AtExt2)
   as [MInj23 [vals3 [ArgsInj23 (*[ArgsHT3*) AtExt3(*]*)]]]; clear core_at_external23.

  (*Prove uniqueness of e, ef_sig, vals3. We do this by hand, instead of
     rewrite AtExtTgt in AtExt3; inv Atext3 in order to avoid the subst
     taht's inherent in inv AtExt3. Probably there's a better way to do this..*)
  assert (e' = e /\ ef_sig' = ef_sig /\ vals3'=vals3).
     rewrite AtExtTgt in AtExt3. inv AtExt3. intuition.
  destruct H as [HH1 [HH2 HH3]].
  rewrite HH1, HH2, HH3 in *. clear HH1 HH2 HH3 e' ef_sig' vals3' AtExt3.

  (*clear MemInjMu. follows from MInj12 MInj23*)
  specialize (eff_after_external12 _ _ _ _ _ _ _ _ _ _ _ _ MInj12
        NormMC12 AtExtSrc AtExt2 ArgsInj12
        _ (eq_refl _) _ (eq_refl _) _ (eq_refl _)).
  specialize (eff_after_external23 _ _ _ _ _ _ _ _ _
      _ _ _ MInj23 MC23 AtExt2 AtExtTgt ArgsInj23 _ (eq_refl _)
      _ (eq_refl _) _ (eq_refl _)).
  assert (LeakedCompSrc: locBlocksSrc mu = locBlocksSrc nmu12 /\
                         extBlocksSrc mu = extBlocksSrc nmu12 /\
                        exportedSrc mu vals1 = exportedSrc nmu12 vals1).
     subst. clear - WDnmu12 WDmu. simpl.
        rewrite restrict_sm_locBlocksSrc.
        rewrite restrict_sm_extBlocksSrc.
        unfold exportedSrc.
        rewrite sharedSrc_iff_frgnpub; trivial. simpl.
        rewrite sharedSrc_iff_frgnpub; trivial.
        rewrite restrict_sm_frgnBlocksSrc, restrict_sm_pubBlocksSrc.
        intuition.
  destruct LeakedCompSrc as [LSa [LSb LSc]].
    rewrite LSa, LSc in *. clear LSa LSb LSc.
  assert (LeakedCompTgt: locBlocksTgt mu = locBlocksTgt mu23
                       /\ extBlocksTgt mu = extBlocksTgt mu23
                       /\ exportedTgt mu vals3 = exportedTgt mu23 vals3).
     subst. clear - WDmu23 WDmu. simpl.
        unfold exportedTgt, sharedTgt. simpl. intuition.
  destruct LeakedCompTgt as [LTa [LTb LTc]].
    rewrite LTa, LTc in *. clear LTa LTb LTc.
   remember (fun b => locBlocksTgt nmu12 b &&
             REACH m2 (exportedTgt nmu12 vals2) b) as pubTgtMid'.
   remember (fun b => locBlocksSrc mu23 b &&
             REACH m2 (exportedSrc mu23 vals2) b) as pubSrcMid'.
   assert (MID: forall b, pubTgtMid' b = true -> pubSrcMid' b = true).
        clear eff_after_external12 match_sm_valid23 eff_after_external23.
        rewrite HeqpubTgtMid', HeqpubSrcMid'.
        destruct GLUEINV as [GlueA [GlueB [GlueC GlueD]]].
        subst.
        clear UnchLOOR13 UnchPrivSrc SEP INC MemInjMu ArgsInj12 MInj12.

        rewrite restrict_sm_locBlocksTgt. (*sm_extern_normalize_exportedTgt; trivial.*)
           rewrite GlueA. intros b Hb. rewrite andb_true_iff in *.
        destruct Hb. split; trivial.
        eapply REACH_mono; try eassumption.
        unfold exportedTgt, exportedSrc, sharedTgt.
        rewrite restrict_sm_frgnBlocksTgt, restrict_sm_pubBlocksTgt.
        rewrite sharedSrc_iff_frgnpub; trivial.
        intros. repeat rewrite orb_true_iff in *.
        intuition.
  assert (NU: nu = compose_sm (replace_locals nmu12 pubSrc' pubTgtMid')
              (replace_locals mu23 pubSrcMid' pubTgt')).
     clear frgnSrcHyp frgnTgtHyp eff_after_external23.
     subst. unfold compose_sm; simpl.
     rewrite replace_locals_extern, replace_locals_local,
             replace_locals_locBlocksSrc, replace_locals_locBlocksTgt,
            replace_locals_pubBlocksSrc, replace_locals_pubBlocksTgt,
            replace_locals_frgnBlocksSrc, replace_locals_frgnBlocksTgt,
            replace_locals_extBlocksSrc, replace_locals_extBlocksTgt.
     rewrite replace_locals_extern, replace_locals_local.
     rewrite restrict_sm_extBlocksSrc, restrict_sm_locBlocksSrc,
             restrict_sm_local, restrict_sm_extern.
     f_equal.

  clear NuHyp.
  (*produce all the hypothesis necessary for applying interpolation*)
  assert (MinjNu12: Mem.inject (as_inj (replace_locals nmu12 pubSrc' pubTgtMid')) m1 m2).
     rewrite replace_locals_as_inj. assumption.
  assert (MinjNu23: Mem.inject (as_inj (replace_locals mu23 pubSrcMid' pubTgt')) m2 m3).
     rewrite replace_locals_as_inj. assumption.
  assert (ArgsInj12R: Forall2
    (val_inject
       (as_inj
          (restrict_sm mu12
             (fun b : block =>
              locBlocksSrc mu12 b || frgnBlocksSrc mu12 b
              || mapped (as_inj (compose_sm mu12 mu23)) b)))) vals1 vals2).
      clear - ArgsInj12 Heqnmu12 HeqRESTR.
      rewrite restrict_sm_all. subst. rewrite restrict_sm_all in ArgsInj12.
       rewrite restrict_nest in ArgsInj12.
       eapply val_list_inject_forall_inject.
       apply forall_inject_val_list_inject in ArgsInj12.
       eapply val_list_inject_incr; try eassumption.
       red; intros. destruct (restrictD_Some _ _ _ _ _ H); clear H.
          unfold vis in H1. rewrite restrict_sm_locBlocksSrc, restrict_sm_frgnBlocksSrc in H1.
          apply restrictI_Some; intuition.
    intros. rewrite effect_properties.vis_restrict_sm in H.
      unfold vis in H. intuition.
  clear ArgsInj12.
  assert (WDnu12: SM_wd (replace_locals nmu12 pubSrc' pubTgtMid')).
       subst.
       eapply replace_locals_wd; try eassumption.
         intros. apply andb_true_iff in H.
           destruct H as [locB R].
           destruct (REACH_local_REACH _ WDnmu12 _ _ _ _
              MInj12 ArgsInj12R _ R locB) as [b2 [d1 [LOC12 R2]]].
           exists b2, d1; split; trivial.
           rewrite andb_true_iff, R2.
           split; trivial.
           eapply local_locBlocks; eassumption.
         intros. apply andb_true_iff in H. apply H.
  assert (ArgsInj23R: Forall2 (val_inject (as_inj mu23)) vals2 vals3).
       eapply val_list_inject_forall_inject.
       apply forall_inject_val_list_inject in ArgsInj23.
       eapply val_list_inject_incr; try eassumption.
       apply restrict_incr.
  clear ArgsInj23.
  assert (WDnu23: SM_wd (replace_locals mu23 pubSrcMid' pubTgt')).
       subst.
       eapply replace_locals_wd; try eassumption.
       destruct GLUEINV as [GIa [GIb [GIc GId]]]. subst.
       intros b2; intros. apply andb_true_iff in H.
           destruct H as [locB R].
           destruct (REACH_local_REACH _ WDmu23 _ _ _ _
              MInj23 ArgsInj23R _ R locB) as [b3 [d2 [LOC23 R3]]].
           exists b3, d2; split; trivial.
           rewrite andb_true_iff, R3.
           split; trivial.
           eapply local_locBlocks; eassumption.
         intros. apply andb_true_iff in H. apply H.
  assert (nu12_valid: sm_valid (replace_locals nmu12 pubSrc' pubTgtMid') m1 m2).
     split. rewrite replace_locals_DOM. eapply mu12_valid.
     rewrite replace_locals_RNG. eapply mu12_valid.
  assert (nu23_valid: sm_valid (replace_locals mu23 pubSrcMid' pubTgt') m2 m3).
     split. rewrite replace_locals_DOM. eapply mu23_valid.
     rewrite replace_locals_RNG. eapply mu23_valid.
  rewrite NU in INC, SEP.
  destruct (EFFAX.effect_interp_II _ _ _ MinjNu12 _ FwdSrc
      _ _ MinjNu23 _ FwdTgt nu' WDnu' SMvalNu' MemInjNu'
      INC SEP nu12_valid nu23_valid)
     as [m2' [nu12' [nu23' [X [Incr12 [Incr23 [MInj12'
        [Fwd2 [MInj23' [Sep12 [Sep23 [nu12'valid
        [nu23'valid [GLUEINV' [Norm' [UnchMidA UnchMidB]]]]]]]]]]]]]]]]; simpl in *.
    (*discharge the unchOn application conditions*)
       subst; apply UnchPrivSrc.
       subst. apply UnchLOOR13.
    (*discharge the GLUE application condition*)
      rewrite replace_locals_extBlocksSrc, replace_locals_extBlocksTgt,
            replace_locals_locBlocksSrc, replace_locals_locBlocksTgt,
            replace_locals_pubBlocksSrc, replace_locals_pubBlocksTgt,
            replace_locals_frgnBlocksSrc, replace_locals_frgnBlocksTgt.
      destruct GLUEINV as [GLUEa [GLUEb [GLUEc GLUEd]]].
      repeat (split; trivial).
      subst. rewrite restrict_sm_locBlocksTgt; trivial.
      subst. rewrite restrict_sm_extBlocksTgt; trivial.
      subst. rewrite restrict_sm_frgnBlocksTgt; trivial.
    (*discharge the Norm Hypothesis*)
      rewrite Heqnmu12. do 2 rewrite replace_locals_extern.
      rewrite restrict_sm_extern.
      intros. destruct (restrictD_Some _ _ _ _ _ H) as [EX12 RR]; clear H.
      subst RESTR nmu12.
     clear UnchLOOR13 UnchPrivSrc Mu'Hyp mu' frgnTgtHyp frgnTgt'
              frgnSrcHyp frgnSrc' FwdTgt FwdSrc RValInjNu' MemInjNu'
              SMvalNu' WDnu' SEP INC m3' m1' ret1 nu'
              pubTgtHyp pubSrcHyp ValInjMu AtExtTgt
              AtExtSrc eff_after_external23
              eff_after_external12 MinjNu23.
      destruct (extern_DomRng _ WDmu12 _ _ _ EX12).
      rewrite (extBlocksSrc_locBlocksSrc _ WDmu12 _ H) in RR; simpl in *.
      remember (frgnBlocksSrc mu12 b1) as d.
      destruct d; apply eq_sym in Heqd.
        destruct (frgnSrc _ WDmu12 _ Heqd) as [bb2 [dd1 [Frg1 FT2]]]; clear Heqd.
        apply foreign_in_extern in Frg1. rewrite Frg1 in EX12; inv EX12.
        destruct GLUEINV as [_ [_ [_ FF]]]. apply FF in FT2.
        destruct (frgnSrc _ WDmu23 _ FT2) as [b3 [d2 [Frg2 FT3]]]; clear FT2.
        rewrite (foreign_in_extern _ _ _ _ Frg2). exists b3, d2; trivial.
      simpl in RR. destruct (mappedD_true _ _ RR) as [[bb dd] M]; clear RR.
        destruct (joinD_Some _ _ _ _ _ M) as [EXT | [EXT LOC]]; clear M;
          rewrite compose_sm_extern in EXT.
          destruct (compose_meminjD_Some _ _ _ _ _ EXT) as [bb2 [dd1 [dd2 [E1 [E2 D]]]]].
          rewrite EX12 in E1. inv E1. rewrite E2. exists bb, dd2; trivial.
        rewrite compose_sm_local in LOC.
          destruct (compose_meminjD_Some _ _ _ _ _ LOC) as [bb2 [dd1 [dd2 [E1 [E2 D]]]]].
          destruct (disjoint_extern_local _ WDmu12 b1); congruence.
  assert (UnchMidC : Mem.unchanged_on (local_out_of_reach (replace_locals mu23 pubSrcMid' pubTgt') m2) m3 m3').
    clear - WDmu23 HeqpubTgtMid' HeqpubSrcMid' MinjNu12 UnchLOOR13 WDnu12 NU pubSrcHyp Heqnmu12 HeqRESTR GLUEINV.
    subst nmu12.
    remember (replace_locals (restrict_sm mu12 RESTR) pubSrc' pubTgtMid') as kappa12.
    remember (replace_locals mu23 pubSrcMid' pubTgt') as kappa23.
    assert (GluePubKappa : forall b : block,
          pubBlocksTgt kappa12 b = true -> pubBlocksSrc kappa23 b = true).
       clear UnchLOOR13 WDnu12 MinjNu12.
       subst kappa12 kappa23. rewrite replace_locals_pubBlocksSrc, replace_locals_pubBlocksTgt.
       subst. rewrite restrict_sm_locBlocksTgt; intros; trivial.
              apply andb_true_iff in H. destruct H.
              destruct GLUEINV as [Ga [Gb [Gc Gd]]]. rewrite Ga in H.
              rewrite H; simpl.
              eapply REACH_mono; try eassumption.
              unfold exportedTgt, exportedSrc, sharedTgt. rewrite sharedSrc_iff_frgnpub.
              rewrite restrict_sm_frgnBlocksTgt, restrict_sm_pubBlocksTgt.
              intros. do 2 rewrite orb_true_iff in H1.
                do 2 rewrite orb_true_iff. intuition.
           assumption.
    clear Heqkappa12 Heqkappa23 GLUEINV.
    subst.
    unfold local_out_of_reach.
    split; intros; rename b into b3.
      destruct H as[locTgt3 LOOR23].
      eapply UnchLOOR13; trivial; simpl.
        split; simpl; trivial.
        intros b1; intros; simpl in *.
        remember (pubBlocksSrc kappa12 b1) as d.
        destruct d; try (right; reflexivity).
        left. apply eq_sym in Heqd.
        destruct (compose_meminjD_Some _ _ _ _ _ H)
          as [b2 [d1 [d2 [LOC1 [LOC2 D]]]]]; subst; clear H.
        destruct (pubSrc _ WDnu12 _ Heqd) as [bb2 [dd1 [Pub12 PubTgt2]]].
        rewrite (pub_in_local _ _ _ _ Pub12) in LOC1. inv LOC1.
        apply GluePubKappa in PubTgt2.
        destruct (LOOR23 _ _ LOC2); clear LOOR23.
          intros N. apply H.
          assert (Arith : ofs - (d1 + d2) + d1 = ofs - d2) by omega.
          rewrite <- Arith.
          eapply MinjNu12. eapply pub_in_all; try eassumption. apply N.
        rewrite H in PubTgt2. discriminate.
    destruct H as[locTgt3 LOOR23].
      eapply UnchLOOR13; trivial; simpl.
        split; trivial.
        intros b1; intros; simpl in *.
        remember (pubBlocksSrc kappa12 b1) as d.
        destruct d; try (right; reflexivity).
        left. apply eq_sym in Heqd.
        destruct (compose_meminjD_Some _ _ _ _ _ H)
          as [b2 [d1 [d2 [LOC1 [LOC2 D]]]]]; subst; clear H.
        destruct (pubSrc _ WDnu12 _ Heqd) as [bb2 [dd1 [Pub12 PubTgt2]]].
        rewrite (pub_in_local _ _ _ _ Pub12) in LOC1. inv LOC1.
        apply GluePubKappa in PubTgt2.
        destruct (LOOR23 _ _ LOC2); clear LOOR23.
          intros N. apply H.
          assert (Arith : ofs - (d1 + d2) + d1 = ofs - d2) by omega.
          rewrite <- Arith.
          eapply MinjNu12. eapply pub_in_all; try eassumption. apply N.
        rewrite H in PubTgt2. discriminate.
  (*next, prepare for application of eff_after_external12*)
  destruct GLUEINV' as [WDnu12' [WDnu23' [GLUEa' [GLUEb' [GLUEc' GLUEd']]]]].
  assert (exists ret2, val_inject (as_inj nu12') ret1 ret2 /\
                       val_inject (as_inj nu23') ret2 ret3 (*/\
                       Val.has_type ret2 (proj_sig_res ef_sig)*)).
    subst. rewrite compose_sm_as_inj in RValInjNu'; trivial.
    destruct (val_inject_split _ _ _ _ RValInjNu')
      as [ret2 [RValInjNu12' RValInjNu23']].
    exists ret2. repeat (split; trivial).
    (*eapply valinject_hastype; eassumption.*)
  destruct H as [ret2 [RValInjNu12' (*[*)RValInjNu23' (*RetType2]*)]].
  subst.
  specialize (eff_after_external12 nu12' ret1
     m1' ret2 m2' Incr12 Sep12 WDnu12' nu12'valid MInj12' RValInjNu12'
     FwdSrc Fwd2 (*RetType2*)).

  destruct (eff_after_external12 _ (eq_refl _)
      _ (eq_refl _) _ (eq_refl _))
    as [d12' [c1' [c2' [AftExt1 [AftExt2 MC12']]]]]; clear eff_after_external12.
   (*discharge unchangedOn-application conditions*)
      apply UnchPrivSrc.
      apply UnchMidB.

  (*next, apply eff_after_external23*)
  specialize (eff_after_external23 nu23').
  destruct (eff_after_external23 ret2 m2'
       ret3 m3' Incr23 Sep23 WDnu23' nu23'valid
       MInj23' RValInjNu23' Fwd2 FwdTgt (*RetTypeTgt*)
     _ (eq_refl _) _ (eq_refl _) _ (eq_refl _)) as
     [d23' [c22' [c3' [AftExt22 [AftExt3 MC23']]]]];
    subst; clear eff_after_external23.
    (*discharge unchangedOn application conditions*)
      apply UnchMidA.
      apply UnchMidC.

  (*finally, instantiate the existentials, and establish conclusion*)
  rewrite AftExt22 in AftExt2. inv AftExt2.
  clear GLUEINV.
  exists (d12', Some c2', d23').
  exists c1'. exists c3'.
  split. assumption.
  split. assumption.
  exists c2'. exists m2'.
  exists (replace_externs nu12'
            (fun b => DomSrc nu12' b && (negb (locBlocksSrc nu12' b)
                                     && REACH m1' (exportedSrc nu12' (ret1::nil)) b))
            (fun b => DomTgt nu12' b && (negb (locBlocksTgt nu12' b)
                                     && REACH m2' (exportedTgt nu12' (ret2::nil)) b))).
  exists (replace_externs nu23'
            (fun b => DomSrc nu23' b && (negb (locBlocksSrc nu23' b)
                                     && REACH m2' (exportedSrc nu23' (ret2::nil)) b))
            (fun b => DomTgt nu23' b && (negb (locBlocksTgt nu23' b)
                                     && REACH m3' (exportedTgt nu23' (ret3::nil)) b))).
  split. reflexivity.
  unfold compose_sm. simpl.
         repeat rewrite replace_externs_extBlocksSrc, replace_externs_extBlocksTgt,
                 replace_externs_locBlocksSrc, replace_externs_locBlocksTgt,
                 replace_externs_pubBlocksSrc, replace_externs_pubBlocksTgt,
                 replace_externs_frgnBlocksSrc, replace_externs_frgnBlocksTgt.
        rewrite replace_externs_extern, replace_externs_local.
        rewrite replace_externs_extern, replace_externs_local.
  split. f_equal; trivial.
         unfold exportedSrc; simpl.
           rewrite sharedSrc_iff_frgnpub; trivial.
           rewrite sharedSrc_iff_frgnpub; trivial.
  clear UnchLOOR13 UnchPrivSrc SEP INC MID UnchMidB Incr12
        Sep12 WDnu12 nu12_valid MinjNu12 UnchMidC UnchMidA Sep23
        Incr23 nu23_valid WDnu23 MinjNu23 MemInjMu ValInjMu.
  split.
    clear MC23' MC12'.
    repeat (split; trivial). unfold DomTgt, DomSrc.
    rewrite GLUEa', GLUEb'.
         intros. do 2 rewrite andb_true_iff.
                 do 2 rewrite andb_true_iff in H.
                 destruct H as [HH1 [HH2 HH3]].
                 split; trivial. split; trivial.
                 eapply REACH_mono; try eassumption.
                 unfold exportedTgt, exportedSrc; intros.
                 apply orb_true_iff. apply orb_true_iff in H.
                 destruct H.
                   left; trivial.
                   right. unfold sharedTgt in H.
                          rewrite sharedSrc_iff_frgnpub.
                          apply orb_true_intro.
                          apply orb_prop in H.
                          destruct H.
                            left. intuition.
                            right. intuition.
               assumption.
   split; assumption.
Qed.

End Eff_sim_trans.


Require Import Coq.Strings.String.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Language.API.
Local Open Scope Z_scope.

Import API.Compilers.
Import Types.Notations.

Section VarnameSet.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters
     width BW word mem locals env ext_spec varname_gen error}.
  Context {listZ : rep.rep base_listZ}.
  Existing Instance rep.Z.

  (* Set of variable names used by an ltype *)
  Fixpoint varname_set_base {t}
    : base_ltype t -> PropSet.set string :=
    match t with
    | base.type.prod a b =>
      fun x => PropSet.union (varname_set_base (fst x))
                             (varname_set_base (snd x))
    | base_listZ => rep.varname_set
    | _ => rep.varname_set
    end.
  Fixpoint varname_set_args {t}
    : type.for_each_lhs_of_arrow ltype t ->
      PropSet.set string :=
    match t as t0 return type.for_each_lhs_of_arrow _ t0 -> _ with
    | type.base b => fun _:unit => PropSet.empty_set
    | type.arrow (type.base a) b =>
      fun (x:base_ltype a * _) =>
        PropSet.union (varname_set_base (fst x))
                      (varname_set_args (snd x))
    | _ => fun _ => PropSet.empty_set (* garbage; invalid argument *)
    end.
  Definition varname_set {t} : ltype t -> PropSet.set string :=
    match t with
    | type.base _ => varname_set_base
    | _ => fun _ => PropSet.empty_set
    end.

  Fixpoint varname_set_listonly {t}
    : base_ltype t ->
      PropSet.set string :=
    match t with
    | base.type.prod a b =>
      fun x => PropSet.union (varname_set_listonly (fst x))
                             (varname_set_listonly (snd x))
    | base_listZ => rep.varname_set
    | _ => fun _ => PropSet.empty_set
    end.
  Fixpoint varname_set_listexcl {t}
    : base_ltype t ->
      PropSet.set string :=
    match t with
    | base.type.prod a b =>
      fun x => PropSet.union (varname_set_listexcl (fst x))
                             (varname_set_listexcl (snd x))
    | base_listZ => fun _ => PropSet.empty_set
    | _ => rep.varname_set
    end.
End VarnameSet.


Require Import Thread Arrays8.

Module Type S.
  Variables globalSched globalSock : W.
End S.

Module Make(M : S).
Import M.

Module M'''.
  Definition globalSched := M.globalSched.

  Open Scope Sep_scope.

  Definition globalInv (fs : files) : HProp := Ex fr, globalSock =*> fr * [| fr %in fs |].
End M'''.

Ltac unf := unfold M'''.globalSched, M'''.globalInv in *.

Module T := Thread.Make(M''').

Import T M'''.
Export T M'''.

Definition hints : TacPackage.
  prepare (materialize_buffer, buffer_split_tagged) buffer_join_tagged.
Defined.

Ltac sep := T.sep unf hints.

Definition handlerS := SPEC reserving 49
  Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0.

Definition mainS := SPEC reserving 49
  PREmain[_] globalSched =?> 1 * globalSock =?> 1 * mallocHeap 0.

Definition writeSomeS := SPEC("fr", "buf", "len") reserving 36
  Al fs, Al len,
  PRE[V] [| V "fr" %in fs |] * V "buf" =?>8 len * [| (wordToNat (V "len") <= len)%nat |]
    * sched fs * globalInv fs * mallocHeap 0
  POST[_] Ex fs', [| fs %<= fs' |] * V "buf" =?>8 len * sched fs' * globalInv fs' * mallocHeap 0.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS],
                           "scheduler"!"init" @ [initS], "scheduler"!"exit" @ [exitS],
                           "scheduler"!"spawn" @ [spawnS], "scheduler"!"listen" @ [listenS],
                           "scheduler"!"accept" @ [acceptS], "scheduler"!"read" @ [readS],
                           "scheduler"!"write" @ [writeS], "scheduler"!"close" @ [closeS] ]]
  bmodule "test" {{
    bfunction "writeSome"("fr", "buf", "len") [writeSomeS]
      Assert [Al fs, Al len,
        PRE[V] [| V "fr" %in fs |] * buffer_splitAt (wordToNat (V "len")) (V "buf") len
          * [| (wordToNat (V "len") <= len)%nat |] * sched fs * globalInv fs * mallocHeap 0
        POST[_] Ex fs', [| fs %<= fs' |] * buffer_joinAt (wordToNat (V "len")) (V "buf") len
          * sched fs' * globalInv fs' * mallocHeap 0];;

      Call "scheduler"!"write"("fr", "buf", "len")
      [PRE[_] Emp POST[_] Emp];;
      Return 0
    end with bfunctionNoRet "handler"("buf", "fr", "n") [handlerS]
      "buf" <-- Call "malloc"!"malloc"(0, 10)
      [Al fs, PREmain[_, R] R =?> 10 * sched fs * globalInv fs * mallocHeap 0];;

      Note [please_materialize_buffer 10];;

      [Al fs, PREmain[V] V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
      While (0 = 0) {
        "fr" <-- Call "scheduler"!"accept"($[globalSock])
        [Al fs, PREmain[V, R] [| R %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0];;

        "n" <-- Call "scheduler"!"read"("fr", "buf", 40)
        [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0];;

        [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
        While ("n" <> 0) {
          If ("n" <= 40) {
            Call "test"!"writeSome"("fr", "buf", "n")
            [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
          } else {
            Skip
          };;

          "n" <-- Call "scheduler"!"read"("fr", "buf", 40)
          [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
        };;

        Call "scheduler"!"close"("fr")
        [Al fs, PREmain[V] V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
      }
    end with bfunctionNoRet "main"("fr", "x") [mainS]
      Init
      [Al fs, Al v, PREmain[_] sched fs * globalSock =*> v * mallocHeap 0];;

      "fr" <-- Call "scheduler"!"listen"(8080%N)
      [Al fs, Al v, PREmain[_, R] [| R %in fs |] * sched fs * globalSock =*> v * mallocHeap 0];;

      globalSock *<- "fr";;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0];;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0];;

      Exit 50
    end
  }}.

Opaque allocated.

Lemma single_cell : forall p,
  (p =?> 1 = (Ex v, p =*> v) * Emp)%Sep.
  auto.
Qed.

Lemma le_40 : forall w : W,
  w <= natToW 40
  -> (wordToNat w <= 40)%nat.
  intros; pre_nomega.
  rewrite wordToNat_natToWord_idempotent in * by reflexivity; omega.
Qed.

Hint Immediate le_40.

Ltac t' := try rewrite (single_cell globalSock); sep; auto.
Ltac t := solve [ t'
  | post; evaluate hints; descend;
    try match goal with
          | [ _ : context[locals ?ns ?X _ _] |- context[locals ?ns ?Y _ _] ] => equate X Y
        end; t' ].

Theorem ok : moduleOk m.
  vcgen; abstract t.
Qed.

End Make.


Require Import Lia IndefiniteDescription Arith.
From hahn Require Import Hahn.
Require Import AuxRel.
Require Import Labels.
Require Import Events.
Require Import Execution.
Require Import View.

Set Implicit Arguments.

Record Message :=
  Msg {
      mloc : Loc ;
      mval : Val ;
      mts  : Timestamp ;
      mview : View }.

Definition Memory := (Message -> Prop).
Definition State := (Memory * (Tid -> View))%type.

Definition Minit : Memory :=
  fun m => mval m = 0 /\ mts m = 0 /\
           mview m = fun _ => 0.

Definition Vinit : View := fun x => 0.
Definition Sinit : State := (Minit, fun tid => Vinit).

Inductive SCOH_label :=
  | SCOH_event (e : Event) (tstamp : Timestamp) (view : View)
  | SCOH_internal (t : Tid) (x : Loc) (tstamp : Timestamp).

Definition deflabel : SCOH_label := SCOH_internal 0 0 0.

Definition read_ts x :=
  match x with
  | SCOH_event _ ts _ => ts
  | SCOH_internal _ _ _ => 0
  end.

Definition write_ts x :=
  match x with
  | SCOH_event _ ts _ => S ts
  | SCOH_internal _ _ _ => 0
  end.

Definition tid_of x :=
  match x with
  | SCOH_event e _ _ => tid e
  | SCOH_internal tid x _ => tid
  end.

Definition is_external x :=
  match x with
  | SCOH_event (ThreadEvent _ _ _) _ _ => True
  | _ => False
  end.

Definition proj_ev x :=
  match x with
  | SCOH_event e _ _ => e
  | SCOH_internal _ _ _ => InitEvent 0
  end.

Definition trproj t :=
  trace_map proj_ev (trace_filter is_external t).

Definition fresh_tstamp (m : Memory) x ts :=
  ~ exists v view, m (Msg x v ts view).

Inductive SCOH_step (MV : State) (e: SCOH_label) (MV' : State) : Prop :=
| SCOHstep_read t i x v tstamp view view'
              (EQ: e = SCOH_event (ThreadEvent t i (Aload x v)) tstamp view')
	      (MSG: fst MV (Msg x v tstamp view))
              (LEV: snd MV t x <= tstamp)
              (MEM: fst MV' = fst MV)
              (EQ': view' = upd (snd MV t) x tstamp)
	      (VIEW: snd MV' = upd (snd MV) t view')
| SCOHstep_write t i x v tstamp view'
               (EQ: e = SCOH_event (ThreadEvent t i (Astore x v)) tstamp view')
               (EQ': view' = upd (snd MV t) x (S tstamp))
               (LTV: snd MV t x < S tstamp)
               (MEM: fst MV' = fst MV ∪₁ eq (Msg x v (S tstamp) view'))
               (FRESH: fresh_tstamp (fst MV) x (S tstamp))
	       (VIEW: snd MV' = upd (snd MV) t view')
| SCOHstep_rmw t i x vr vw tstamp view view'
             (EQ: e = SCOH_event (ThreadEvent t i (Armw x vr vw)) tstamp view')
	     (MSG: fst MV (Msg x vr tstamp view))
             (LEV: snd MV t x <= tstamp)
             (EQ' : view' = upd (snd MV t) x (S tstamp))
             (MEM: fst MV' = fst MV ∪₁ eq (Msg x vw (S tstamp) view'))
             (FRESH: fresh_tstamp (fst MV) x (S tstamp))
             (VIEW: snd MV' = upd (snd MV) t view')
| SCOHstep_internal t x v tstamp view view'
                  (EQ: e = SCOH_internal t x tstamp)
		  (MSG: fst MV (Msg x v tstamp view))
                  (LEV: snd MV t x < tstamp)
                  (MEM: fst MV' = fst MV)
                  (EQ': view' = upd (snd MV t) x tstamp)
		  (VIEW: snd MV' = upd (snd MV) t view').

Definition scoh_lts :=
  {| LTS_init := eq Sinit ;
     LTS_step := SCOH_step ;
     LTS_final := ∅ |}.

Definition run_fair (states : nat -> State) t : Prop :=
  match t with
  | trace_fin _ => True
  | trace_inf fl =>
    exists (threads : Tid -> Prop),
    set_finite threads /\
    trace_elems t ⊆₁ tid_of ↓₁ threads /\
    forall i (tid : Tid) (TID: threads tid) x tstamp,
    exists j,
      i <= j /\
      (fl j = SCOH_internal tid x tstamp \/
       forall st'
              (STEP: SCOH_step (states j) (SCOH_internal tid x tstamp) st'),
         False)
  end.

Definition SCOH_is_w lab :=
  match lab with
  | SCOH_event (ThreadEvent _ _ (Astore _ _)) ts view => True
  | SCOH_event (ThreadEvent _ _ (Armw _ _ _)) ts view => True
  | _ => False
  end.

Definition SCOH_wmsg lab :=
  match lab with
  | SCOH_event (ThreadEvent t i (Astore x v)) ts view => Msg x v (S ts) view
  | SCOH_event (ThreadEvent t i (Armw x vr vw)) ts view => Msg x vw (S ts) view
  | _ => Msg 0 0 0 (fun _ => 0)
  end.

Definition view_of x :=
  match x with
  | SCOH_event _ _ view => view
  | SCOH_internal _ _ _ => fun _ => 0
  end.

Inductive match_ev (e : Event) (l : SCOH_label) : Prop :=
| ME_case t i lab tstamp view (EQe : e = ThreadEvent t i lab)
          (EQl : l = SCOH_event e tstamp view).

Definition view_of' t x :=
  match excluded_middle_informative
          (exists xl, match_ev x xl /\ trace_elems t xl) with
  | left IN =>
    view_of (proj1_sig
               (IndefiniteDescription.constructive_indefinite_description
                  _ IN))
  | right _ => fun _ => 0
  end.

Lemma view_of_init t x :
  view_of' t (InitEvent x) = fun _ => 0.
Proof using.
  unfold view_of'; desf.
  exfalso; desf; destruct e; desf.
Qed.

Lemma SCOH_step_view_mono mem lab mem'
      (STEP : SCOH_step mem lab mem') t :
  view_le (snd mem t) (snd mem' t).
Proof using.
  destruct STEP; ins; desf; ins.
  all: rewrite VIEW; clear VIEW; unfold upd; desf.
  all: try apply view_le_join_l.
  all: red; unfold upd; ins; desf; lia.
Qed.

Lemma SCOH_step_view_ext mem lab mem'
      (STEP : SCOH_step mem lab mem')
      (EXT : is_external lab) :
  view_le (snd mem (tid_of lab))
          (view_of lab) /\
  view_of lab = snd mem' (tid_of lab).
Proof using.
  destruct STEP; ins; desf; ins.
  all: rewrite VIEW, upds; split; ins.
  all: try apply view_le_join_l.
  all: red; unfold upd; ins; desf; lia.
Qed.

Lemma SCOH_view_mono mem lab
      (STEP : forall i, SCOH_step (mem i) (lab i) (mem (S i)))
      i j (LE : i <= j) mytid x :
  snd (mem i) mytid x <= snd (mem j) mytid x.
Proof using.
  induction j; rewrite Nat.le_lteq in LE; desf; try lia.
  rewrite Nat.lt_succ_r in *; intuition.
  eapply Nat.le_trans, SCOH_step_view_mono; eauto.
Qed.

Section RADeclarative.

Variable G: execution.

Definition scoh_consistent :=
  SCpL G  /\
  irreflexive ((rf G)⁻¹ ⨾ (co G ⨾ (co G))) /\
  << PORF : irreflexive (hb G) >>.

Lemma hb_irr (CONS : scoh_consistent) : irreflexive (hb G).
Proof using. apply CONS. Qed.

Lemma scoh_rmw_atomicity (WF: Wf G) (CONS : scoh_consistent) :
  rmw_atomicity G.
Proof using.
  unfold scoh_consistent, rmw_atomicity in *; desc.
  rewrite wf_rfE, wf_rfD; ins; unfolder in *; ins; desf.
  destruct (classic (x = y)) as [|NEQ]; desf.
  { edestruct (CONS y). apply ct_step.
    basic_solver. }
  eapply (wf_co_total WF) in NEQ; ins; desf; ins.
  { splits; ins; intro; desf; eauto 10. }
  { edestruct (CONS x). apply ct_ct.
    exists y; split; apply t_step; basic_solver. }
  unfolder. splits; auto.
  apply wf_rfl in H0; ins.
Qed.

Lemma scoh_rf_irr (CONS : scoh_consistent) : irreflexive (rf G).
Proof using. rewrite rf_in_hb. by apply hb_irr. Qed.

Lemma rf_w_in_co (WF: Wf G) (CONS : scoh_consistent) :
  (rf G) ⨾ ⦗is_w⦘ ⊆ (co G).
Proof using.
  unfolder. intros x y [RF WY].
  destruct (classic (x = y)) as [|NEQ]; subst.
  { exfalso. eapply scoh_rf_irr; eauto. }
  apply (wf_rfE WF) in RF. unfolder in RF. desf.
  apply (wf_rfD WF) in RF0. unfolder in RF0. desf.
  edestruct (wf_co_total WF) with (a:=x) (b:=y) as [|HH]; eauto.
  1,2: unfolder; splits; eauto.
  { symmetry. by apply (wf_rfl WF). }
  exfalso.
  cdes CONS. eapply CONS0.
  apply ct_ct. eexists. split; apply ct_step.
  all: basic_solver.
Qed.

(* TODO: move to more appropriate place or replace with co_ninit. *)
Lemma co_init_r (WF: Wf G)
      x y (CO : co G x y) (INITY : is_init y) :
  False.
Proof.
  apply co_ninit in CO; auto. unfolder in CO. desf.
Qed.

End RADeclarative.