Require Import compcert.lib.Coqlib.
Require Import compcert.common.Memtype.
Require Import compcert.common.AST.
Require Import compcert.common.Events.
Require Import compcert.common.Globalenvs.
Require Import compcert.cfrontend.Ctypes.
Require Import compcert.x86.Asm.
Require Import compcertx.x86.AsmX.
Require Import liblayers.lib.Decision.
Require Import liblayers.logic.LayerData.
Require Import liblayers.logic.Layers.
Require Export liblayers.compcertx.CompcertStructures.
Require Import liblayers.compcertx.ErrorMonad.
Require Import liblayers.compcertx.AbstractData.
Require Import liblayers.compcertx.AbstractData.
Require Import liblayers.compat.CompatData.
Require Export liblayers.compat.CompatCPrimitives.
Require Export liblayers.compat.CompatAsmPrimitives.
Require Export liblayers.compat.CompatCallConv.
Open Scope positive_scope.

(** * Combined primitives *)

(** We should define a conversion from C primitive semantics to
  assembly primitive semantics. For now, we want to stick to the way
  existing proofs are done (ie. duplicated), and we just define the
  sum of both kinds. *)

Section COMBINED_PRIMITIVES.
Context `{Hmem: Mem.MemoryModel}.
Context `{Hmwd: UseMemWithData mem}.

(** ** Definition *)

Definition compatsem (D: compatdata) :=
  (sextcall_primsem D + sprimcall_primsem D)%type.

Definition compatsem_sig D (σ: compatsem D): signature :=
  match σ with
    | inl σl => sextcall_sig σl
    | inr σr => sprimcall_sig σr
  end.

(** Helps with unification. *)
Definition compatsem_inl {D}: sextcall_primsem D -> compatsem D := inl.
Definition compatsem_inr {D}: sprimcall_primsem D -> compatsem D := inr.

(** ** Order *)

Inductive compatsem_le (D: compatdata): relation (compatsem D) :=
  | compatsem_le_inl:
      Proper (sextcall_primsem_le ++> compatsem_le D) compatsem_inl
  | compatsem_le_inr:
      Proper (sprimcall_primsem_le ++> compatsem_le D) compatsem_inr.

Global Existing Instance compatsem_le_inl.
Global Existing Instance compatsem_le_inr.

Hint Resolve (compatsem_le_inl: forall D σ1 σ2, _ σ1 σ2 -> _) : liblayers.
Hint Resolve (compatsem_le_inr: forall D σ1 σ2, _ σ1 σ2 -> _) : liblayers.

Global Instance compatsem_le_preorder D:
  PreOrder (compatsem_le D).
Proof.
  split.
  * intros [σl | σr]; constructor; reflexivity.
  * intros _ _ σ3 [σl1 σl2 Hl12 | σr1 σr2 Hr12] H23;
    inversion H23 as [σl2x σl3 Hl23 | σr2x σr3 Hr23]; subst; clear H23;
    constructor;
    etransitivity;
    eassumption.
Qed.

Require Import OptionMonad.

(** ** Simulation diagrams *)

Record sextcall_sprimcall_sim {D1 D2} (R: compatrel D1 D2)
       (sem1: sextcall_primsem D1) (sem2: sprimcall_primsem D2): Prop :=
  {
    sextcall_sprimcall_sim_step:
                forall f vargs1 vargs2 vres m1 d1 m1' d1' rs2 m2 (d2: D2),
                (** Invariants *)
                forall (LOW_LEVEL_INVARIANT: low_level_invariant (Mem.nextblock m2) d2),
                forall (L_HIGH_LEVEL_INVARIANT: high_level_invariant d2),
                forall (H_HIGH_LEVEL_INVARIANT: high_level_invariant d1),
                (** Higher-layer semantics *)
                forall (SEM1: sem1 (decode_longs (sig_args (sextcall_sig sem1)) vargs1) (m1, d1) vres (m1', d1')),
                (** Match states *)
                forall (MATCH: MatchExtcallStates R f m1 d1 m2 d2),
                (** Calling convention *)
                forall (ARGS_INJ: val_list_inject f vargs1 vargs2),
                forall (EXTCALL_ARG: Asm.extcall_arguments rs2 (m2, d2) (sextcall_sig sem1) vargs2),
                (** Requirements of the compiler (to make "transitivity" possible) *)
                forall (ASM_INV: asm_invariant rs2 (m2, d2)),
                (*
      forall (KERNEL_MODE: kernel_mode d2),
                 *)
                forall (SP_NOT_VUNDEF: rs2 (Asm.IR Asm.ESP) <> Vundef),
                forall (RA_NOT_VUNDEF: rs2 Asm.RA <> Vundef),
                forall (INIT_SP_NOT_GLOBAL:
                          forall (b : Values.block) (o : Integers.Int.int),
                            rs2 (Asm.IR Asm.ESP) = Values.Vptr b o ->
                            Ple glob_threshold b),
                exists f' rs2' m2' d2',
                  sprimcall_step sem2 rs2 (m2, d2) rs2' (m2', d2') /\
                  MatchExtcallStates R f' m1' d1' m2' d2' /\
                  inject_incr f f' /\
                  val_list_inject f'
                                  (encode_long (sig_res (sextcall_sig sem1)) vres)
                                  (map rs2' (loc_external_result (sextcall_sig sem1))) /\
                  (forall r,
                     ~ In r Conventions1.destroyed_at_call ->
                     Val.lessdef (rs2 (preg_of r)) (rs2' (preg_of r)))
                  /\ Val.lessdef (rs2 RA) (rs2' Asm.PC)
                  /\ Val.lessdef (rs2 ESP) (rs2' ESP);
    sextcall_sprimcall_sim_sig:
      sprimcall_sig sem2 = sextcall_sig sem1;
    sextcall_sprimcall_sim_invs:
      ExtcallInvariants sem1
  }.

(** We want to relate [sextcall_sprimcall_sim] with [callconv_primsem].
  One particularly challenging aspect is to establish that the final
  register states are related. In particular, we need to use the
  condition on [vres] to establish that the registers encoding it
  in [rs1] inject into [rs2]. *)

Lemma callconv_encode_result_item_inject f v reg regs rs1 rs2:
  (- ==> val_inject f) rs1 rs2 ->
  val_inject f v (rs2 reg) ->
  (prod_rel (- ==> val_inject f) eq)
    (callconv_encode_result_item (rs1, reg::regs) v)
    (rs2, regs).
Proof.
  intros Hrs Hv.
  split; eauto; simpl.
  intros reg'.
  unfold Pregmap.set.
  destruct (PregEq.eq _ _); subst; eauto.
Qed.

Lemma callconv_encode_result_items f (regs: list preg) vs (rs1 rs2: regset):
  (val_list_inject f) vs (map rs2 regs) ->
  (- ==> val_inject f) rs1 rs2 ->
  (- ==> val_inject f)
    (fst (fold_left callconv_encode_result_item vs (rs1, regs)))
    rs2.
Proof.
  change rs1 with (fst (rs1, regs)) at 1.
  change regs with (snd (rs1, regs)) at 1.
  generalize (rs1, regs) as rr.
  clear.
  induction vs as [ | v vs IHvs]; eauto.
  intros [rs1 regs] Hvs Hrs.
  destruct regs as [ | reg regs]; inversion Hvs; subst.
  apply IHvs; clear IHvs; simpl in *; eauto.
  intros reg'.
  unfold Pregmap.set.
  destruct (PregEq.eq _ _); subst; eauto.
Qed.

Lemma callconv_encode_result_inject f sg v rs1 rs2:
  (val_list_inject f)
    (encode_long (sig_res sg) v)
    (map rs2 (loc_external_result sg)) ->
  (- ==> val_inject f) rs1 rs2 ->
  (- ==> val_inject f) (callconv_encode_result sg v rs1) rs2.
Proof.
  apply callconv_encode_result_items.
Qed.

(** Furthermore, in order to do case analysis in terms if what happens
  to what register and use the conditions expressed in terms of
  [Machregs.mreg], we need to be able to distiguish whether a given
  [preg] is in the codomain of [preg_of]. *)

Definition mregs: list preg :=
  FR XMM0 :: FR XMM1 :: FR XMM2 :: FR XMM3 ::
  FR XMM4 :: FR XMM5 :: FR XMM6 :: FR XMM7 ::
  IR EAX  :: IR EBX  :: IR ECX  :: IR EDX  ::
  IR ESI  :: IR EDI  :: IR EBP  :: ST0     ::
  nil.

Lemma mregs_correct:
  forall r, In r mregs -> exists m, r = preg_of m.
Proof.
  intros [|[]|[]| |[]|] H;
  let rec tryall l :=
    match l with
      | ?m :: ?ms =>
        (exists m; reflexivity) || tryall ms
      | _ =>
        contradict H; decision
    end in
  tryall
    (Machregs.AX ::
     Machregs.BX ::
     Machregs.CX ::
     Machregs.DX ::
     Machregs.SI ::
     Machregs.DI ::
     Machregs.BP ::
     Machregs.X0 ::
     Machregs.X1 ::
     Machregs.X2 ::
     Machregs.X3 ::
     Machregs.X4 ::
     Machregs.X5 ::
     Machregs.X6 ::
     Machregs.X7 ::
     Machregs.FP0 ::
     nil).
  Qed.

Lemma mregs_complete:
  forall m, In (preg_of m) mregs.
Proof.
  intros []; decision.
Qed.

Lemma sextcall_sprimcall_sim_elim {D1 D2} (R: compatrel D1 D2) sem1 sem2:
  sextcall_sprimcall_sim R sem1 sem2 ->
  sprimcall_sim R (callconv_primsem D1 sem1) sem2.
Proof.
  intros [Hstep Hsig Hinvs].
  constructor; eauto.
  * intros f rs1 m1 d1 rs1' m1' d1' rs2 m2 d2.
    intros Hll2 Hhl2 Hhl1 Hasm H1 Hmatch.
    destruct H1 as (vargs1 & vres1 & [Hstep1 Hvargs1 Hsp Hra Hspng Hvres1]).
    destruct Hmatch as [Hmatch Hrs].
    apply extcall_arguments_lift in Hvargs1.
    edestruct extcall_arguments_inject as (vargs2 & Hvargs & Hvargs2); eauto.
    {
      apply match_inject.
    }
    edestruct Hstep as (f' & rs2' & m2' & d2' & H); eauto.
    + apply extcall_arguments_lift; assumption.
    + eapply val_inject_defined; eauto.
    + eapply val_inject_defined; eauto.
    + intros b ofs Hrs2.
      specialize (Hrs ESP).
      unfold Pregmap.get in Hrs.
      destruct Hrs; inversion Hrs2; subst; eauto; try congruence.
      apply match_inject_forward in H.
      destruct H; subst.
      transitivity b1; eauto.
      eapply Hspng; eauto.
    + destruct H as (Hstep2 & Hmatch' & Hf & Hvres & Hrd & HRAPC & HESP).
      exists f', rs2', m2', d2'.
      split; eauto.
      split; eauto.
      subst.
      intros reg.
      unfold callconv_final_regs.
      unfold Pregmap.get.
      apply callconv_encode_result_inject; eauto.
      unfold Pregmap.set.
      clear reg; intro reg.
      destruct (PregEq.eq reg PC); subst.
      {
        rewrite <- HRAPC.
        eauto.
      }
      unfold callconv_destroy_regs.
      unfold callconv_destroyed_regs.
      destruct (decide _) as [Hregd|Hregd]; try constructor.
      destruct (decide (In reg mregs)) as [Hregm|Hregm].
      {
        apply mregs_correct in Hregm.
        destruct Hregm as [r Hr]; subst.
        rewrite <- Hrd; eauto.
        intros H.
        apply Hregd.
        apply in_app; left.
        apply in_map; eauto.
      }
      {
        destruct reg as [|[]|[]| |[]|];
        try (contradict Hregm; decision);
        try (contradict Hregd; decision);
        try congruence.
        (* Only ESP left *)
        rewrite <- HESP.
        eauto.
      }
  * apply callconv_invariants in Hinvs.
    assumption.
Qed.

Inductive compatsim_def {D1 D2: compatdata} (R: compatrel D1 D2):
  compatsem D1 -> compatsem D2 -> Prop :=
    | sextcall_sim_either_sim sem1 sem2:
        sextcall_sim R sem1 sem2 ->
        compatsim_def R (compatsem_inl sem1) (compatsem_inl sem2)
    | sprimcall_sim_either_sim sem1 sem2:
        sprimcall_sim R sem1 sem2 ->
        compatsim_def R (compatsem_inr sem1) (compatsem_inr sem2)
    | sextcall_sprimcall_sim_either_sim sem1 sem2:
        sprimcall_sim R (callconv_primsem D1 sem1) sem2 ->
        ExtcallInvariants sem1 ->
        compatsim_def R (compatsem_inl sem1) (compatsem_inr sem2).

Global Instance compatsim_def_le {D1 D2} (R: compatrel D1 D2):
  Proper (compatsem_le D1 --> compatsem_le D2 ++> impl) (compatsim_def R).
Proof.
    intros σ1 σ1' H1 σ2 σ2' H2 H.
    unfold flip in *; simpl in *.
    destruct H as [sem1 sem2 Hl | sem1 sem2 Hr | sem sem2 Hlr].

    + (* extcall *)
      inversion H1 as [sem1' sem1x Hsem1 | ]; subst; clear H1.
      inversion H2 as [sem2x sem2' Hsem2 | ]; subst; clear H2.
      constructor.
      eapply sextcall_sim_le; eauto.

    + (* primcall *)
      inversion H1 as [ | sem1' sem1x Hsem1]; subst; clear H1.
      inversion H2 as [ | sem2x sem2' Hsem2]; subst; clear H2.
      constructor.
      eapply sprimcall_sim_le; eauto.

    + (* heterogenous *)
      inversion H1 as [ | sem1' sem1x Hsem1]; subst; clear H1.
      inversion H2 as [ | sem2x sem2' Hsem2]; subst; clear H2.
      constructor.
      * eapply sprimcall_sim_le; eauto.
        eapply callconv_primsem_le_monotonic.
        assumption.
      * destruct Hlr as [_ _ Hvalid _]; simpl in Hvalid.
        destruct Hsem2 as [_ _ Hvalid2].
        eapply (sextcall_primsem_le_invs x sem); eauto.
Qed.

Definition compatsim {D1 D2}:
  path compatrel D1 D2 -> compatsem D1 -> compatsem D2 -> Prop :=
  path_sim compatsem_le (@compatsim_def) D1 D2.

Global Instance compat_sim_op: Sim (path compatrel) compatsem | 1 :=
  path_sim_op compatsem_le (@compatsim_def).

Global Instance compat_primsem_ops: PrimitiveOps compatsem :=
  {
    (*prim_union := compatsem_union*)
  }.

Global Instance compatsem_primsem_prf:
  Primitives compatsem.
Proof.
  split; try typeclasses eauto.
  * apply path_sim_prf; typeclasses eauto.
Qed.

(** Convenient shortcut for defining primitives as [p ↦ csem sem]. *)

Definition csem {D: compatdata} (sem: sextcall_sem (mem := mwd D)) targs tres :=
  compatsem_inl
    {|
      sextcall_primsem_step :=
        {|
          sextcall_step := sem;
          sextcall_csig := mkcsig targs tres
        |};
      sextcall_props := Error (MSG "missing extcall properties"::nil);
      sextcall_invs := Error (MSG "primitive does not preserve invariants"::nil)
    |}.

Definition null_signature :=
  {| sig_args := nil; sig_res := None; sig_cc := cc_default |}.

Definition asmsem {D: compatdata} (sem: sprimcall_sem (mem := mwd D)) :=
  compatsem_inr
    {|
      sprimcall_primsem_step :=
        {|
          sprimcall_step := sem;
          sprimcall_sig := null_signature
        |};
      sprimcall_props := Error (MSG "missing primcall properties"::nil);
      sprimcall_invs := Error (MSG "primitive does not preserve invariants"::nil)
    |}.

Definition asmsem_withsig {D: compatdata} (sem: sprimcall_sem (mem := mwd D)) sig :=
  compatsem_inr
    {|
      sprimcall_primsem_step :=
        {|
          sprimcall_step := sem;
          sprimcall_sig := sig
        |};
      sprimcall_props := Error (MSG "missing primcall properties"::nil);
      sprimcall_invs := Error (MSG "primitive does not preserve invariants"::nil)
    |}.

End COMBINED_PRIMITIVES.


From compcert Require Import common.AST cfrontend.Ctypes cfrontend.Clight.
Import Cop.
Require Import VST.floyd.base2.
Require Import VST.floyd.functional_base.
Require Import VST.floyd.client_lemmas.
Require Import VST.floyd.compare_lemmas.
Require Import VST.floyd.nested_pred_lemmas.
Require Import VST.floyd.nested_field_lemmas.
Require Import VST.floyd.efield_lemmas.
Require Import VST.floyd.mapsto_memory_block.
Require Import VST.floyd.aggregate_type.
Require VST.floyd.aggregate_pred. Import floyd.aggregate_pred.aggregate_pred.
Require Import VST.floyd.reptype_lemmas.
Require Import VST.floyd.simpl_reptype.
Require Import VST.floyd.data_at_rec_lemmas.
Require Import VST.floyd.field_at.
Require Import VST.floyd.field_at_wand.
Require Import VST.floyd.field_compat.
Require Import VST.floyd.stronger.
Require Import VST.floyd.proj_reptype_lemmas.
Require Import VST.floyd.replace_refill_reptype_lemmas.
Require Import VST.floyd.unfold_data_at.
Require Import VST.floyd.entailer.

Lemma
  sbyte_ubyte_convert:
  forall i j,
  Int.sign_ext 8 (Int.repr (Byte.unsigned i)) = Int.repr (Byte.signed j) <->
  Int.zero_ext 8 (Int.repr (Byte.unsigned i)) = Int.repr (Byte.unsigned j).
Proof.
intros.
rewrite Int.zero_ext_and by computable.
simpl.
normalize.
transitivity (Z.land (Byte.unsigned i) 255 = Byte.unsigned j).
2:{
split; intro. f_equal; auto.
apply repr_inj_unsigned; auto.
split. apply Z.land_nonneg; rep_lia.
change 255 with (Z.ones 8).
rewrite (Z.land_ones (Byte.unsigned i) 8 ) by computable.
pose proof (Z_mod_lt (Byte.unsigned i) (2^8)).
spec H0.
compute; auto.
change (2^8) with 256 in *. rep_lia.
rep_lia.
}
change 255 with (Z.ones 8).
rewrite Z.land_ones_low; try rep_lia.
2:{
pose proof (Z.log2_le_mono (Byte.unsigned i) 255).
simpl in H.
spec H; rep_lia.
}
split; intro.
-
apply Z.bits_inj.
intro n.
destruct (zlt n 0).
rewrite !Z.testbit_neg_r by auto. auto.
destruct (zlt n 8).
2:{
assert (forall k, Z.log2 (Byte.unsigned k) < n).
intro. assert (Byte.unsigned k <= 255) by rep_lia.
apply Z.log2_le_mono in H0. simpl in H0. lia.
rewrite Z.bits_above_log2 by (auto; rep_lia).
rewrite Z.bits_above_log2 by (auto; rep_lia).
auto.
}
apply (f_equal (fun i => Int.testbit i n)) in H.
rewrite Int.bits_sign_ext in H by (change Int.zwordsize with 32; lia).
rewrite if_true in H by auto.
rewrite !Int.testbit_repr in H by (change Int.zwordsize with 32; lia).
rewrite H; clear H.
rewrite Byte.bits_signed by lia.
rewrite if_true by auto.
reflexivity.
-
rewrite H.
clear H.
apply Int.same_bits_eq; intros n  ?.
change Int.zwordsize with 32 in H.
rewrite Int.bits_sign_ext by (auto; computable).
if_tac.
rewrite !Int.testbit_repr by auto.
rewrite Byte.bits_signed by lia.
rewrite if_true by auto.
reflexivity.
rewrite !Int.testbit_repr by (change Int.zwordsize with 32; lia).
rewrite Byte.bits_signed by lia.
rewrite if_false by auto.
reflexivity.
Qed.

Module M.
Import VST.veric.base.
Import VST.msl.predicates_hered.
Import VST.veric.res_predicates.

Lemma address_mapsto_any_sbyte_ubyte:
 forall sh b z,
 EX v2' : val, address_mapsto Mint8signed v2' sh (b, z) =
 EX v2' : val, address_mapsto Mint8unsigned v2' sh (b, z).
Proof.
intros.
apply pred_ext;
[pose (f := Byte.unsigned) | pose (f := Byte.signed)];
apply exp_left; intro v;
pose (v' := match v with Vint j => Vint (Int.repr (f (Byte.repr (Int.unsigned j))))
  | _ => Vundef
end);
apply exp_right with v';
unfold address_mapsto;
apply exp_left; intro bl;
apply exp_right with bl;
apply prop_andp_left; intros [? [? ?]];
destruct bl as [| ? [|]]; try solve [inv H];
(rewrite prop_true_andp; [auto |
  split3; auto; unfold decode_val in *; destruct m; subst v v' f; simpl in *; auto;
   unfold decode_int; rewrite rev_if_be_singleton; simpl; rewrite Z.add_0_r;
   f_equal; clear
  ]).
all: assert (Int.zwordsize = 32) by reflexivity;
      assert (Byte.zwordsize = 8) by reflexivity.
all: apply Int.same_bits_eq; intros n ?;
rewrite ?Int.bits_zero_ext by lia;
rewrite ?Int.bits_sign_ext by lia;
rewrite ?Int.testbit_repr by (try if_tac; lia);
rewrite ?Byte.bits_signed by lia;
change (Z.testbit (Byte.unsigned ?A)) with (Byte.testbit A);
rewrite ?Byte.testbit_repr by (try if_tac; lia);
rewrite ?H0; if_tac;
rewrite ?Byte.testbit_repr by (try if_tac; lia).
rewrite <- Int.testbit_repr by lia; rewrite Int.repr_unsigned.
rewrite Int.bits_sign_ext by lia.
rewrite if_true by lia.
rewrite Int.testbit_repr by lia.
reflexivity.
rewrite Byte.bits_above by lia. auto.
rewrite <- Int.testbit_repr by lia; rewrite Int.repr_unsigned.
rewrite Int.bits_zero_ext by lia.
rewrite if_true by auto.
rewrite Int.testbit_repr by lia.
reflexivity.
rewrite <- Int.testbit_repr by lia; rewrite Int.repr_unsigned.
rewrite Int.bits_zero_ext by lia.
rewrite if_true by lia.
rewrite Int.testbit_repr by lia.
reflexivity.
Qed.
End M.

Arguments deref_noload ty v / .
Arguments nested_field_array_type {cs} t gfs lo hi / .
Arguments nested_field_type {cs} t gfs / .  (* redundant? *)
Arguments nested_field_offset {cs} t gfs / .  (* redundant? *)
Arguments Z.mul !x !y.
Arguments Z.sub !m !n.
Arguments Z.add !x !y.
Global Transparent peq.

Lemma data_at_tarray_tschar_tuchar {cs: compspecs}:
  forall sh n bytes p,
  data_at sh (tarray tschar n) (map Vbyte bytes) p = data_at sh (tarray tuchar n) (map Vubyte bytes) p.
Proof.
intros.
unfold data_at, field_at.
f_equal.
f_equal.
unfold field_compatible.
simpl.
apply prop_ext; intuition; destruct p; auto;
hnf in H2|-*;
apply align_compatible_rec_Tarray; intros;
apply align_compatible_rec_Tarray_inv with (i:=i0) in H2; auto;
eapply align_compatible_rec_by_value_inv in H2; try reflexivity;
eapply align_compatible_rec_by_value; try reflexivity;
apply H2.
unfold at_offset.
simpl.
rewrite !data_at_rec_eq.
simpl.
apply array_pred_ext.
change (Zlength (map Vbyte bytes) = Zlength (map Vubyte bytes)).
autorewrite with sublist. auto.
intros.
unfold at_offset.
autorewrite with sublist.
rewrite !data_at_rec_eq; simpl.
do 2 change (unfold_reptype ?A) with A.
change (sizeof tschar) with 1.
change (sizeof tuchar) with 1.
forget (offset_val (1 * i) (offset_val 0 p)) as q.
simpl.
destruct q; auto.
unfold mapsto; simpl.
if_tac; auto.
-
simpl.
f_equal; auto; [f_equal; auto | ].
+
f_equal.
destruct (zlt i (Zlength bytes)).
rewrite !Znth_map by lia.
simpl.
apply prop_ext; split; intro;
autorewrite with norm norm1 norm2; rep_lia.
rewrite !Znth_overflow by (autorewrite with sublist; auto).
reflexivity.
+
do 2 change (unfold_reptype ?A) with A.
destruct (zlt i (Zlength bytes)).
2:
 rewrite !Znth_overflow by (autorewrite with sublist; auto);
 unfold res_predicates.address_mapsto; simpl;
 f_equal;
 extensionality bl;
 f_equal; f_equal;
 apply prop_ext; intuition;
 destruct bl as [| ? [|]]; inv H3;
 destruct m; inv H; reflexivity.
autorewrite with sublist.
forget (Znth i bytes) as c.
unfold res_predicates.address_mapsto; simpl.
f_equal.
extensionality bl.
f_equal.
f_equal.
 apply prop_ext; intuition;
 destruct bl as [| ? [|]]; inv H3;
 destruct m; try solve [inv H];
 unfold decode_val, proj_bytes in *;
 unfold Vubyte, Vbyte in *;
  apply Vint_inj in H;
  f_equal; clear - H;
unfold decode_int in *;
rewrite rev_if_be_1 in H|-*;
simpl in H|-*;
rewrite Z.add_0_r in *;
apply sbyte_ubyte_convert; auto.
+
f_equal; auto.
f_equal.
repeat change (unfold_reptype ?A) with A.
destruct (zlt i (Zlength bytes)).
autorewrite with sublist.
apply prop_ext; split; intro Hx; inv Hx.
rewrite !Znth_overflow by (autorewrite with sublist; auto).
apply prop_ext; split; intro; reflexivity.
clear.
forget (Ptrofs.unsigned i0) as z.
apply M.address_mapsto_any_sbyte_ubyte.
-
f_equal.
f_equal.
f_equal.
unfold tc_val'.
destruct (zlt i (Zlength bytes)).
autorewrite with sublist.
apply prop_ext; split; intros.
red. simpl. normalize. rep_lia.
red. simpl. normalize. rep_lia.
rewrite !Znth_overflow by (autorewrite with sublist; auto).
apply prop_ext; split; intros; contradiction H2; auto.
Qed.

Require Import VST.msl.iter_sepcon.
Require Import VST.floyd.go_lower.
Import ListNotations.

Section ArrayPointer.

Context {cs: compspecs}.

(*For simplifying pointer arithmetic*)
Lemma sem_sub_pi_offset: forall ty s off n,
  isptr s ->
  complete_type cenv_cs ty = true ->
  Int.min_signed <= n <= Int.max_signed ->
  force_val (sem_sub_pi ty Signed (offset_val off s) (Vint (Int.repr n))) =
  offset_val (off - (sizeof ty) * n) s.
Proof.
  intros ty s off n Hptr Hty Hn.
  replace (off - (sizeof ty) * n) with (off + (- (sizeof ty) * n)) by lia. rewrite <- offset_offset_val.
  assert (Hptr' : isptr (offset_val off s)). rewrite isptr_offset_val; auto.
  destruct (offset_val off s) eqn : Hoff; inversion Hptr'. simpl.
  unfold sem_sub_pi. rewrite Hty. simpl. f_equal. unfold sizeof.
  assert ((Ptrofs.of_ints (Int.repr n)) = Ptrofs.repr n). unfold Ptrofs.of_ints.
  f_equal. apply Int.signed_repr; auto. rewrite H. rewrite ptrofs_mul_repr.
  rewrite Ptrofs.sub_add_opp. f_equal. replace (- Ctypes.sizeof ty * n) with (-(Ctypes.sizeof ty * n)) by lia.
  rewrite <- (Ptrofs.neg_repr). reflexivity.
Qed.

(** Indexing into arrays **)

Lemma arr_field_compatible0 : forall t size p i,
  field_compatible (tarray t size) [] p ->
  0 <= i <= size ->
  field_compatible0 (tarray t size) (SUB i) p.
Proof.
  intros t size p i Hcomp Hsz.
  unfold field_compatible in *. unfold field_compatible0. destruct Hcomp as [Hptr [Hleg [Hsz_comp [Hal Hnest]]]].
  repeat(split; auto).
Qed.

Lemma arr_field_address0: forall t size p i,
  field_compatible (tarray t size) [] p ->
  0 <= i <= size ->
  field_address0 (tarray t size) (SUB i) p = offset_val (sizeof t * i) p.
Proof.
  intros t size p i Hcomp Hi.
  unfold field_address0. destruct (field_compatible0_dec (tarray t size) (SUB i) p).
  simpl. auto. exfalso. apply n. apply arr_field_compatible0; auto.
Qed.

Lemma arr_field_compatible : forall t size p i,
  field_compatible (tarray t size) [] p ->
  0 <= i < size ->
  field_compatible (tarray t size) (SUB i) p.
Proof.
  intros t size p i Hcomp Hsz.
  unfold field_compatible in *. unfold field_compatible0. destruct Hcomp as [Hptr [Hleg [Hsz_comp [Hal Hnest]]]].
  repeat(split; auto).
Qed.

Lemma arr_field_address: forall t size p i,
  field_compatible (tarray t size) [] p ->
  0 <= i < size ->
  field_address (tarray t size) (SUB i) p = offset_val (sizeof t * i) p.
Proof.
  intros t size p i Hcomp Hi.
  unfold field_address. destruct (field_compatible_dec (tarray t size) (SUB i) p).
  simpl. auto. exfalso. apply n. apply arr_field_compatible; auto.
Qed.

(*Useful for proving that pointers are valid for conditionals*)
Lemma isptr_denote_tc_test_order: forall p1 p2,
  isptr p1 ->
  isptr p2 ->
  denote_tc_test_order p1 p2 = test_order_ptrs p1 p2.
Proof.
  intros p1 p2 Hptr1 Hptr2. destruct p1; destruct Hptr1. destruct p2; destruct Hptr2. reflexivity.
Qed.

(** Lemmas about [sameblock] *)

Lemma isptr_offset_val_sameblock : forall p i,
  isptr p ->
  sameblock p (offset_val i p) = true.
Proof.
  intros. destruct p; destruct H.
  simpl. unfold proj_sumbool. apply peq_true.
Qed.

Lemma sameblock_refl : forall p,
  isptr p ->
  sameblock p p = true.
Proof.
  intros.
  destruct p; destruct H. apply peq_true.
Qed.

Lemma sameblock_symm : forall p1 p2,
  sameblock p1 p2 = true ->
  sameblock p2 p1 = true.
Proof.
  intros.
  destruct p1; destruct p2; try discriminate.
  simpl in *. destruct (peq b b0); try discriminate.
  subst.
  apply peq_true.
Qed.

Lemma sameblock_trans : forall p1 p2 p3,
  sameblock p1 p2 = true ->
  sameblock p2 p3 = true->
  sameblock p1 p3 = true.
Proof.
  intros.
  destruct p1; try discriminate.
  destruct p2; try discriminate.
  destruct p3; try discriminate.
  simpl in *.
  destruct (peq b b0); try discriminate.
  destruct (peq b0 b1); try discriminate.
  subst.
  apply peq_true.
Qed.

Lemma sameblock_offset_val: forall p n1 n2,
  isptr p ->
  sameblock (offset_val n1 p) (offset_val n2 p) = true.
Proof.
  intros p n1 n2 Hptr. eapply sameblock_trans. eapply sameblock_symm.
  all: apply isptr_offset_val_sameblock; auto.
Qed.

(** Simplifying Pointer Comparisons *)

(* Suppose there is an array of length s, and 2 pointers to elements in the array n and m, and the
   C expression n > m (in a loop guard or conditional). This gives a long, difficult proof obligation.
   The next few lemmas convert this into something usable. *)

(* > case *)
Lemma ptr_comparison_gt_iff: forall t size p i j,
  field_compatible (tarray t size) [] p ->
  0 <= i <= size ->
  0 <= j <= size ->
  0 < sizeof t ->
  isptr p ->
  typed_true tint (force_val (sem_cmp_pp Cgt (field_address0 (tarray t size) (SUB i) p)
    (field_address0 (tarray t size) (SUB j) p))) <-> i > j.
Proof.
  intros t size p i j Hcomp Hi Hj Hszof Hptr.
  assert (Hptri : isptr (field_address0 (tarray t size) (SUB i) p)).
  apply field_address0_isptr. apply arr_field_compatible0; auto.
  assert (Hptrj: isptr (field_address0 (tarray t size) (SUB j) p)).
  apply field_address0_isptr. apply arr_field_compatible0; auto.
  rewrite force_sem_cmp_pp; auto. unfold compare_pp.
  destruct (field_address0 (tarray t size) (SUB i) p) eqn : Fi; inversion Hptri.
  destruct (field_address0 (tarray t size) (SUB j) p) eqn : Fj; inversion Hptrj.
  clear Hptri Hptrj.
  assert (Hsame: sameblock (Vptr b i0) (Vptr b0 i1) = true). { rewrite <- Fi. rewrite <- Fj.
  rewrite !arr_field_address0; auto. eapply sameblock_trans. apply sameblock_symm.
  all: apply  isptr_offset_val_sameblock; auto. }
  simpl in Hsame. unfold eq_block. destruct (peq b b0); try inversion Hsame. subst. clear Hsame.
  simpl. rewrite arr_field_address0 in Fi; auto. rewrite arr_field_address0 in Fj; auto.
  destruct p; inversion Hptr. simpl in *. inversion Fi; subst. inversion Fj; subst.
  clear Fi Fj Hptr. unfold Ptrofs.ltu.
  assert (Hi2 : 0 <= Ptrofs.unsigned i2) by rep_lia. unfold field_compatible in Hcomp.
  destruct Hcomp as [Ht [Hcomp [HHsz Hrest]]]. simpl in HHsz.
  replace (Z.max 0 size) with size in HHsz by lia.
  (*We will use these a bunch of times*)
  assert (Hij: forall k, 0 <= k <= size -> 0 <= sizeof t * k < Ptrofs.modulus). {
    intros k Hk. unfold sizeof in *. split. lia.
    assert (Ctypes.sizeof t * k <= Ctypes.sizeof t * size).  apply Z.mul_le_mono_pos_l; lia.
    assert (Ctypes.sizeof t * size < Ptrofs.modulus) by lia. lia. }
  assert (Hij' : forall k, 0 <= k <= size ->
      0 <= Ptrofs.unsigned i2 + Ptrofs.unsigned (Ptrofs.repr (sizeof t * k)) < Ptrofs.modulus). {
    intros k Hk. unfold sizeof in *. rewrite Ptrofs.unsigned_repr_eq. rewrite Zmod_small.
    2: apply Hij; lia. split. lia.
    assert (Ptrofs.unsigned i2 + Ctypes.sizeof t * k <= Ptrofs.unsigned i2 + Ctypes.sizeof t * size).
    apply Zplus_le_compat_l. apply Z.mul_le_mono_nonneg_l; lia. eapply Z.le_lt_trans. apply H. assumption. }
  unfold Ptrofs.unsigned. simpl. rewrite !Ptrofs.Z_mod_modulus_eq. rewrite !Zmod_small.
  all: try apply Hij'; auto.
  destruct (zlt (Ptrofs.unsigned i2 + Ptrofs.unsigned (Ptrofs.repr (sizeof t * j)))
          (Ptrofs.unsigned i2 + Ptrofs.unsigned (Ptrofs.repr (sizeof t * i)))).
    - assert (Hptrlt: Ptrofs.unsigned (Ptrofs.repr (sizeof t * j)) < Ptrofs.unsigned (Ptrofs.repr (sizeof t * i))) by lia.
      clear l. unfold Ptrofs.unsigned in Hptrlt. simpl in Hptrlt. rewrite !Ptrofs.Z_mod_modulus_eq in Hptrlt.
      rewrite !Zmod_small in Hptrlt. rewrite <- Z.mul_lt_mono_pos_l in Hptrlt; auto. all: try apply Hij; auto.
      split; intros; auto. lia. reflexivity.
    - assert (Hptrlt: Ptrofs.unsigned (Ptrofs.repr (sizeof t * i)) <= Ptrofs.unsigned (Ptrofs.repr (sizeof t * j))) by lia.
      clear g. unfold Ptrofs.unsigned in Hptrlt. simpl in Hptrlt. rewrite !Ptrofs.Z_mod_modulus_eq in Hptrlt.
      rewrite !Zmod_small in Hptrlt. rewrite <- Z.mul_le_mono_pos_l in Hptrlt; auto. all: try apply Hij; auto.
      split; intros; try lia. inversion H.
Qed.

(*Switch Cgt and Clt*)
Lemma cgt_clt_ptr: forall p1 p2,
  sem_cmp_pp Cgt p1 p2 = sem_cmp_pp Clt p2 p1.
Proof.
  intros p1 p2. unfold sem_cmp_pp. simpl. f_equal. unfold Val.cmplu_bool.
  destruct p1; destruct p2; auto.
  destruct (Archi.ptr64); auto; simpl;
  destruct (eq_block b b0), (eq_block b0 b); subst; try contradiction;
  reflexivity.
Qed.

(*Same for the lt case. This is an easy corollary of the above 2 lemmas*)
Lemma ptr_comparison_lt_iff: forall t size p i j,
  field_compatible (tarray t size) [] p ->
  0 <= i <= size ->
  0 <= j <= size ->
  0 < sizeof t ->
  isptr p ->
  typed_true tint (force_val (sem_cmp_pp Clt (field_address0 (tarray t size) (SUB i) p)
    (field_address0 (tarray t size) (SUB j) p))) <-> i < j.
Proof.
  intros t sz p i j Hcompat Hi Hj Ht Hptr. rewrite <- cgt_clt_ptr.
  rewrite ptr_comparison_gt_iff by auto. lia.
Qed.

(** Working with 2D Arrays*)

(*We can consider an instance of t at position p to be a valid array of length 1 at p*)
Lemma data_at_array_len_1: forall sh t a p,
data_at sh t a p |-- !! field_compatible (tarray t 1) [] p.
Proof.
  intros. erewrite <- data_at_singleton_array_eq. 2: reflexivity. entailer!.
Qed.

(*The crucial lemma for showing the relationship between 1D and 2D arrays: if we shift 1 array (in the 2D array)
  or m places (in the 1D array), the result is still compatible*)
Lemma field_compatible0_1d_2d: forall n m t p,
  0 <= m ->
  0 < n ->
  field_compatible (Tarray t m noattr) [] p ->
  (field_compatible0 (tarray (tarray t m) n)) (SUB 1) p <->
  (field_compatible0 (tarray t (n * m)) (SUB m) p).
Proof.
  intros n m t p Hm Hn Hfst.
  unfold field_compatible in Hfst. unfold field_compatible0.
  simpl in *. destruct Hfst as [Hptr1 [Hleg1 [Hszc1 [Hal1 Hlegn1]]]].
  clear Hlegn1.
  (*The interesting part*)
  assert (size_compatible (tarray (tarray t m) n) p /\ align_compatible (tarray (tarray t m) n) p <->
    size_compatible (tarray t (n * m)) p /\ align_compatible (tarray t (n * m)) p ). {
   unfold size_compatible. destruct p; inversion Hptr1. simpl in *.
    replace (Z.max 0 m) with m by lia.
    replace (Z.max 0 n) with n by lia.
    replace (Z.max 0 (n * m)) with (m * n) by lia.
    rewrite Z.mul_assoc. split; intros [Hszc2 Hal2].
    - split. assumption. inversion Hal2; subst. inversion H.
      inversion Hal1; subst. inversion H.
      apply align_compatible_rec_Tarray. intros j Hj.
      assert (m = 0 \/ m > 0) by lia. destruct H as [H | Hm0]. subst. lia.
      assert (0 <= j < m \/ m <= j < n * m) by lia. destruct H as [Hfst | Hrest].
      + specialize (H4 _ Hfst). apply H4.
      + (*To index into the rest of the array, we need to use j/ m and j %m, which gives lots of annoying proof obligations*)
        assert (0 <= j / m  < n). { split. assert (1 <= j / m). rewrite <- (Z_div_same _ Hm0).
        apply Z_div_le; lia. lia. apply Z.div_lt_upper_bound; lia. }
        specialize (H3 _ H). clear H4. inversion H3; subst. inversion H0.
        assert (0 <= j mod m < m). { apply Z.mod_pos_bound; lia. }
        specialize (H5 _ H0). replace (Ptrofs.unsigned i + Ctypes.sizeof t * j) with
        (Ptrofs.unsigned i + Ctypes.sizeof (tarray t m) * (j / m) + Ctypes.sizeof t * (j mod m)). apply H5.
        rewrite <- !Z.add_assoc. f_equal. simpl Ctypes.sizeof. replace (Z.max 0 m) with m by lia.
        rewrite <- Z.mul_assoc. rewrite <- Z.mul_add_distr_l. f_equal.
        replace (Z.max 0 m) with m by lia.
        rewrite <- Z_div_mod_eq_full. reflexivity.
    - split. assumption. inversion Hal2; subst. inversion H.
      inversion Hal1; subst. inversion H.  apply align_compatible_rec_Tarray. intros j Hj.
      apply align_compatible_rec_Tarray. intros k Hk.
      assert (0 = j \/ 1 <= j) by lia. destruct H as [Hfst | Hrest].
      + subst. rewrite Z.mul_0_r. rewrite Z.add_0_r. apply H4. apply Hk.
      + assert (0 = m \/ 0 < m) by lia. destruct H as [H | Hm0]. lia.
        assert (0 <= j * m + k < n * m). { split; try lia.
        assert (j * m + k < j * m + m) by lia. replace (j * m + m) with ((j+1) * m) in H by lia.
        assert ((j+1) * m <= n * m). apply Zmult_le_compat_r; lia. lia. }
        specialize (H3 _ H). simpl. replace ( Z.max 0 m ) with m by lia.
        replace (Ptrofs.unsigned i + Ctypes.sizeof t * m * j + Ctypes.sizeof t * k) with
        (Ptrofs.unsigned i + Ctypes.sizeof t * (j * m + k)). apply H3. rewrite <- !Z.add_assoc. f_equal.
        rewrite <- Z.mul_assoc. rewrite <- Z.mul_add_distr_l. f_equal. lia. }
  split; intros [Hptr2 [Hleg2 [Hszc2 [Hal2 [Hlegn2 Hbound2]]]]].
  repeat(split; auto). apply H. split; auto.
  apply H. split; auto. replace m with (1 * m) at 1 by lia. apply Z.mul_le_mono_nonneg_r; lia.
  repeat(split; auto). apply H. split; auto. apply H; split; auto. lia. lia.
Qed.

Lemma Zlength_concat': forall {A: Type} (n m : Z) (l: list (list A)),
  Zlength l = n ->
  Forall (fun x => Zlength x = m) l ->
  Zlength (concat l) = n * m.
Proof.
  intros A m n l. revert m. induction l; intros.
  - list_solve.
  - simpl. rewrite Zlength_app. rewrite (IHl (m-1)). 2: list_solve.
    assert (Zlength a = n). inversion H0; subst; reflexivity. rewrite H1. lia. inversion H0; auto.
Qed.

(*The full relationship between 1D and 2D arrays*)
Lemma data_at_2darray_concat : forall sh t n m (al : list (list (reptype t))) p,
  Zlength al = n ->
  Forall (fun l => Zlength l = m) al ->
  complete_legal_cosu_type t = true ->
  data_at sh (tarray (tarray t m) n) al p
    = data_at sh (tarray t (n * m)) (concat al) p.
Proof.
  intros.
  generalize dependent n; generalize dependent p; induction al; intros.
  - simpl. replace n with 0 by list_solve. rewrite Z.mul_0_l.
    apply pred_ext; entailer!; rewrite !data_at_zero_array_eq; auto.
  - rewrite Zlength_cons in H. simpl. assert (Hmlen: Zlength a = m) by (inversion H0; subst; reflexivity).
    apply pred_ext.
    + (*We will need these later, when we have transformed the [data_at] predicates, so they are harder to prove*)
      assert_PROP (field_compatible (tarray (tarray t m) (Z.succ (Zlength al))) [] p). { entailer!. }
      assert_PROP (field_compatible0 (tarray (tarray t m) n) (SUB 1) p). { entailer!.
        apply arr_field_compatible0. auto. list_solve. }
      change (a :: al) with ([a] ++ al).
      change (list (reptype t)) with (reptype (tarray t m)) in a.
      rewrite (split2_data_at_Tarray_app 1 _ _ _ [a]). 2: Zlength_solve.
      change (reptype (tarray t m)) with  (list (reptype t)) in a. 2: { rewrite <- H.
      assert (forall x, x = Z.succ x - 1). intros; lia. apply H4. }
      rewrite (split2_data_at_Tarray_app m).
      replace (n * m - m) with ((n-1) * m) by lia.
      erewrite data_at_singleton_array_eq. 2: reflexivity.
      assert (Hm: 0 <= m). rewrite <- Hmlen. list_solve.
      entailer!. rewrite !field_address0_clarify; auto.
      simpl. unfold sizeof. rewrite <- Z.mul_assoc.
      replace (Z.max 0 (Zlength a) * 1) with (Zlength a) by lia. rewrite IHal. cancel.
      inversion H0; subst; auto. lia. unfold field_address0.
      rewrite field_compatible0_1d_2d in H3.
      destruct (field_compatible0_dec (tarray t (Z.succ (Zlength al) * Zlength a)) [ArraySubsc (Zlength a)] p); [| contradiction].
    apply isptr_is_pointer_or_null; auto. list_solve. list_solve. auto.
    inversion H0; subst; reflexivity.
    rewrite (Zlength_concat' (n-1) m). lia. list_solve. inversion H0; auto.
    + assert_PROP ((field_compatible0 (tarray t (n * m)) [ArraySubsc m] p)). { entailer!.
      apply arr_field_compatible0. apply H2.
       split. list_solve. rewrite <- (Z.mul_1_l (Zlength a)) at 1. apply Z.mul_le_mono_nonneg_r; list_solve. }
      change (a :: al) with ([a] ++ al).
      change (list (reptype t)) with (reptype (tarray t m)) in a.
      rewrite (split2_data_at_Tarray_app 1 _ _ _ [a]). 2: Zlength_solve.
      change (reptype (tarray t m)) with  (list (reptype t)) in a. 2: { rewrite <- H.
      assert (forall x, x = Z.succ x - 1). intros; lia. apply H3. }
      rewrite (split2_data_at_Tarray_app m). 2: auto.
      replace (n * m - m) with ((n-1) * m) by lia.
      erewrite data_at_singleton_array_eq. 2: reflexivity.
      assert (Hm: 0 <= m). rewrite <- Hmlen. list_solve.
      entailer!. rewrite !field_address0_clarify; auto.
      simpl. unfold sizeof. rewrite <- Z.mul_assoc.
      replace (Z.max 0 (Zlength a) * 1) with (Zlength a) by lia. rewrite IHal. cancel.
      inversion H0; subst; auto. lia. unfold field_address0.
      rewrite <- field_compatible0_1d_2d in H2.
      destruct (field_compatible0_dec (tarray (tarray t (Zlength a)) (Z.succ (Zlength al))) [ArraySubsc 1] p); [| contradiction].
      apply isptr_is_pointer_or_null; auto. list_solve. list_solve. auto.
      rewrite (Zlength_concat' (n-1) m). lia. list_solve. inversion H0; auto.
Qed.

(** Working with Arrays of Pointers **)

(*Represents the fact that there is a list of pointers (ptrs), and the contents of those pointers
  are described by contents - a 2D array with possibly different lengths.
  This definition applies to byte arrays (so we don't need to worry about offsets), but it
  could be extended. *)
Definition iter_sepcon_arrays (ptrs : list val) (contents: list (list byte)) :=
  iter_sepcon (fun (x: (list byte * val)) => let (l, ptr) := x in
            data_at Ews (tarray tuchar (Zlength l)) (map Vubyte l) ptr) (combine contents ptrs).

Lemma iter_sepcon_arrays_Znth: forall ptrs contents i,
  Zlength ptrs = Zlength contents ->
  0 <= i < Zlength contents ->
  iter_sepcon_arrays ptrs contents |--
    data_at Ews (tarray tuchar (Zlength (Znth i contents))) (map Vubyte (Znth i contents)) (Znth i ptrs) * TT.
Proof.
  intros ptrs contents i Hlen Hi. unfold iter_sepcon_arrays.
  sep_apply (iter_sepcon_in_true (fun x : list byte * val => let (l, ptr) := x in
    data_at Ews (tarray tuchar (Zlength l)) (map Vubyte l) ptr) (combine contents ptrs)
    (Znth i contents, Znth i ptrs)); [|cancel].
  rewrite In_Znth_iff. exists i. split. rewrite Zlength_combine; lia.
  apply Znth_combine; lia.
Qed.

Lemma remove_lead_eq: forall {A: Type} (P: Prop) (x: A),
  (x = x -> P) <-> P.
Proof.
  intros. tauto.
Qed.

Lemma iter_sepcon_arrays_local_facts: forall ptrs contents,
  iter_sepcon_arrays ptrs contents |-- !! (Zlength ptrs = Zlength contents ->
        forall i, 0 <= i < Zlength contents ->
         field_compatible (tarray tuchar (Zlength (Znth i contents))) [] (Znth i ptrs) /\
         Forall (value_fits tuchar) (map Vubyte (Znth i contents))).
Proof.
  intros ptrs contents.
  assert (Zlength ptrs = Zlength contents \/ Zlength ptrs <> Zlength contents) as [Heq | Hneq] by lia;
  [ | entailer!]. rewrite Heq, remove_lead_eq. eapply derives_trans. 2:
  apply (@allp_prop_left _ _ Z (fun (i: Z) => 0 <= i < Zlength contents ->
        field_compatible (tarray tuchar (Zlength (Znth i contents))) [] (Znth i ptrs) /\
        Forall (value_fits tuchar) (map Vubyte (Znth i contents)))).
  apply allp_right. intros i.
  (*This is not particularly elegant; is there a way to get an implication out directly?*)
  assert (0 <= i < Zlength contents \/ ~ (0 <= i < Zlength contents)) as [Hlt | Hgt] by lia; [| entailer ].
  sep_apply (iter_sepcon_arrays_Znth _ _ _ Heq Hlt).
  assert (forall m (P : Type) Q, P -> (m |-- !! Q) -> (m |-- !! (P -> Q))). { intros. sep_apply H. entailer!. }
  apply H. assumption. entailer!.
Qed.

(*We would also like another, more general fact. For [iter_sepcon] that gives an mpred
  as well as [iter_sepcon_arrays]), we can remove
  the nth element and keep the rest*)

(*An easier definition than [delete_nth], since it uses Z and there are lots of lemmas/automation about sublist*)
Definition remove_nth {A: Type} (n: Z) (l: list A): list A :=
  sublist 0 n l ++ sublist (n+1) (Zlength l) l.

Lemma iter_sepcon_remove_one: forall {B : Type} `{Inhabitant B} (p: B -> mpred) (l: list B) (n: Z),
  0 <= n < Zlength l ->
  iter_sepcon p l = ((p (Znth n l)) * iter_sepcon p (remove_nth n l))%logic.
Proof.
  intros B Hinhab p l n Hn. unfold remove_nth. rewrite <- (sublist_same 0 (Zlength l) l) at 1 by auto.
  rewrite (sublist_split 0 n (Zlength l) l) by lia.
  rewrite (sublist_split n (n+1) (Zlength l) l) by lia. rewrite !iter_sepcon_app.
  rewrite sublist_len_1 by lia. simpl. apply pred_ext; cancel.
Qed.

Lemma combine_sublist: forall {A B: Type} `{Inhabitant A} `{Inhabitant B} (lo hi : Z) (l1 : list A) (l2: list B),
  Zlength l1 = Zlength l2 ->
  0 <= lo <= hi ->
  hi <= Zlength l1 ->
  combine (sublist lo hi l1) (sublist lo hi l2) = sublist lo hi (combine l1 l2).
Proof.
  intros A B Hinh1 Hinh2 lo hi l1 l2 Hlen Hhilo Hhi.
  assert (Hsublen: Zlength (combine (sublist lo hi l1) (sublist lo hi l2)) = hi - lo). {
   rewrite Zlength_combine by (rewrite !Zlength_sublist; lia). list_solve. }
  apply Znth_eq_ext. rewrite Hsublen. rewrite Zlength_sublist; try lia.
  rewrite Zlength_combine; lia.
  intros i Hi. rewrite Hsublen in Hi. rewrite Znth_combine by list_solve.
  rewrite !Znth_sublist by lia. rewrite Znth_combine by lia. reflexivity.
Qed.

Lemma combine_remove_nth: forall {A B: Type} `{Inhabitant A} `{Inhabitant B} n (l1: list A) (l2: list B),
  Zlength l1 = Zlength l2 ->
  0 <= n < Zlength l1 ->
  combine (remove_nth n l1) (remove_nth n l2) = remove_nth n (combine l1 l2).
Proof.
  intros A B Hinh1 Hinh2 n l1 l2 Hlens Hn.
  unfold remove_nth. rewrite combine_app' by list_solve. rewrite Hlens, !combine_sublist by lia.
  rewrite Zlength_combine by lia. rewrite Hlens, Z.min_id. reflexivity.
Qed.

(* Allows one to extract a single [data_at] from an [iter_sepcon] without losing any information *)
Lemma iter_sepcon_arrays_remove_one: forall ptrs contents i,
  Zlength ptrs = Zlength contents ->
  0 <= i < Zlength contents ->
  iter_sepcon_arrays ptrs contents =
    (data_at Ews (tarray tuchar (Zlength (Znth i contents))) (map Vubyte (Znth i contents)) (Znth i ptrs) *
    iter_sepcon_arrays (remove_nth i ptrs) (remove_nth i contents))%logic.
Proof.
  intros ptrs contents i Hlens Hi. unfold iter_sepcon_arrays. rewrite (iter_sepcon_remove_one _ _ i).
  rewrite Znth_combine by auto. f_equal. rewrite combine_remove_nth by lia. reflexivity.
  rewrite Zlength_combine; lia.
Qed.

End ArrayPointer.

(** Convert [data_at] for numeric types *)

Section DataAtNumeric.

Context `{cs: compspecs}.

(*Helper lemmas*)
Lemma exp_equiv: forall {A} (f: A -> predicates_hered.pred compcert_rmaps.RML.R.rmap),
  exp f = predicates_hered.exp f.
Proof.
  intros. reflexivity.
Qed.

Lemma andp_pull1:
  forall P (A C: predicates_hered.pred compcert_rmaps.RML.R.rmap), predicates_hered.andp (predicates_hered.andp (predicates_hered.prop P) A) C =
                 predicates_hered.andp (predicates_hered.prop P)  (predicates_hered.andp A C).
Proof.
intros.
apply predicates_hered.andp_assoc.
Qed.

Lemma decode_int_single: forall (b: byte),
  decode_int [b] = Byte.unsigned b.
Proof.
  intros b. unfold decode_int. unfold rev_if_be.
  destruct Archi.big_endian; simpl; lia.
Qed.

Lemma zero_ext_8_lemma:
  forall i j, Int.zero_ext 8 (Int.repr (Byte.unsigned i)) = Int.repr (Byte.unsigned j) ->
    i=j.
Proof.
intros.
rewrite zero_ext_inrange in H
  by (rewrite Int.unsigned_repr by rep_lia; simpl; rep_lia).
apply repr_inj_unsigned in H; try rep_lia.
rewrite <- (Byte.repr_unsigned i), <- (Byte.repr_unsigned j).
congruence.
Qed.

Lemma decode_val_Vubyte_inj:
  forall i j, decode_val Mint8unsigned [Byte i] = Vubyte j -> i=j.
Proof.
intros.
unfold decode_val, Vubyte in *; simpl in *.
apply Vint_inj in H.
rewrite decode_int_single in *.
apply zero_ext_8_lemma in H.
auto.
Qed.

Lemma decode_int_range: forall bl, 0 <= decode_int bl < two_p (Z.of_nat (Datatypes.length bl) * 8).
Proof.
intros.
unfold decode_int.
unfold rev_if_be.
destruct Archi.big_endian.
rewrite <- rev_length.
apply int_of_bytes_range.
apply int_of_bytes_range.
Qed.

Lemma int_of_bytes_inj: forall al bl, length al = length bl -> int_of_bytes al = int_of_bytes bl -> al=bl.
Proof.
intros.
revert bl H H0; induction al; destruct bl; simpl; intros; auto; try discriminate.
pose proof (Byte.unsigned_range a). pose proof (Byte.unsigned_range i).
change Byte.modulus with 256 in *.
assert (al=bl). {
   apply IHal. congruence.
   forget (int_of_bytes al) as x. forget (int_of_bytes bl) as y.
   lia.
}
subst bl.
f_equal.
clear - H0 H1 H2.
rewrite <- (Byte.repr_unsigned a).
rewrite <- (Byte.repr_unsigned i).
f_equal.
lia.
Qed.

Lemma decode_int_inj: forall al bl,
   length al = length bl ->
   decode_int al = decode_int bl -> al=bl.
Proof.
intros.
unfold decode_int in *.
apply int_of_bytes_inj in H0; auto.
Qed.

(** Convert between 4 bytes and int *)
Lemma address_mapsto_4bytes_aux:
 forall (sh : Share.t)
   (b0 b1 b2 b3 : byte)
   (b : block) (i : ptrofs)
   (SZ : Ptrofs.unsigned i + 4 < Ptrofs.modulus)
(*   (AL : (4 | Ptrofs.unsigned i)) *)
   (r : readable_share sh),
predicates_sl.sepcon
  (predicates_sl.sepcon
     (predicates_sl.sepcon
           (predicates_hered.allp
              (res_predicates.jam
                 (adr_range_dec (b, Ptrofs.unsigned i) (size_chunk Mint8unsigned))
                 (fun loc : address =>
                  res_predicates.yesat compcert_rmaps.RML.R.NoneP
                    (compcert_rmaps.VAL
                       (nth (Z.to_nat (snd loc - snd (b, Ptrofs.unsigned i)))
                          [Byte b0] Undef)) sh loc) res_predicates.noat))
           (predicates_hered.allp
              (res_predicates.jam
                 (adr_range_dec (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 1)))
                    (size_chunk Mint8unsigned))
                 (fun loc : address =>
                  res_predicates.yesat compcert_rmaps.RML.R.NoneP
                    (compcert_rmaps.VAL
                       (nth
                          (Z.to_nat
                             (snd loc
                                - snd
                                    (b,
                                    Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 1)))))
                          [Byte b1] Undef)) sh loc) res_predicates.noat)))
        (predicates_hered.allp
           (res_predicates.jam
              (adr_range_dec (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 2)))
                 (size_chunk Mint8unsigned))
              (fun loc : address =>
               res_predicates.yesat compcert_rmaps.RML.R.NoneP
                 (compcert_rmaps.VAL
                    (nth
                       (Z.to_nat
                          (snd loc
                             - snd
                                 (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 2)))))
                       [Byte b2] Undef)) sh loc) res_predicates.noat)))
     (predicates_hered.allp
        (res_predicates.jam
           (adr_range_dec (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 3)))
              (size_chunk Mint8unsigned))
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth
                    (Z.to_nat
                       (snd loc
                          - snd (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 3)))))
                    [Byte b3] Undef)) sh loc) res_predicates.noat))
          = predicates_hered.allp
                                    (res_predicates.jam
                                       (adr_range_dec (b, Ptrofs.unsigned i)
                                          (size_chunk Mint32))
                                       (fun loc : address =>
                                        res_predicates.yesat
                                          compcert_rmaps.RML.R.NoneP
                                          (compcert_rmaps.VAL
                                             (nth
                                                (Z.to_nat
                                                   (snd loc
                                                      - snd (b, Ptrofs.unsigned i)))
                                                [Byte b0; Byte b1; Byte b2; Byte b3]
                                                Undef)) sh loc) res_predicates.noat).
Proof.
intros.

     simpl snd.
    simpl size_chunk.
 repeat   match goal with |- context [Ptrofs.add i (Ptrofs.repr ?A)] =>
    replace (Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr A)))
    with (A + Ptrofs.unsigned i)
    by (unfold Ptrofs.add; rewrite (Ptrofs.unsigned_repr (Z.pos _)) by rep_lia;
        rewrite Ptrofs.unsigned_repr by rep_lia; rep_lia)
   end.
    rewrite  (res_predicates.allp_jam_split2 _ _ _
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
                    [Byte b0; Byte b1; Byte b2; Byte b3] Undef)) sh loc)
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
                    [Byte b0; Byte b1; Byte b2] Undef)) sh loc)
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - (3+Ptrofs.unsigned i)))
                    [Byte b3] Undef)) sh loc)
           (adr_range_dec (b, Ptrofs.unsigned i) 4)
           (adr_range_dec (b, Ptrofs.unsigned i) 3)
           (adr_range_dec (b, 3 + Ptrofs.unsigned i) 1)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
           [Byte b0; Byte b1; Byte b2; Byte b3] Undef)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
           [Byte b0; Byte b1; Byte b2] Undef)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - (3+Ptrofs.unsigned i)))
           [Byte b3] Undef)).
    2:{ forget (Ptrofs.unsigned i) as j. clear.
         split; intros [b1 z1]. simpl. intuition rep_lia.
         simpl. intuition rep_lia.
       }
    2:{ intros. destruct l; destruct H; subst. f_equal. f_equal.
          rewrite (app_nth1 [Byte b0; Byte b1; Byte b2] [Byte b3]); auto.
        simpl. rep_lia.
       }
  2:{ intros. f_equal. f_equal.
       destruct l; destruct H. subst b4. simpl snd.
       assert (z = 3 + Ptrofs.unsigned i) by lia. subst z.
        rewrite Z.sub_diag.
        replace (3 + Ptrofs.unsigned i - Ptrofs.unsigned i) with 3 by lia.
          reflexivity.
      }
   2:{ intros. left. destruct H0. hnf in H0. rewrite H0 in H1 . clear H0.
        destruct l, H. subst. simpl snd in *.
        assert (Z.to_nat (z - Ptrofs.unsigned i) < 4)%nat by rep_lia.
        clear - H1. destruct (Z.to_nat (z - Ptrofs.unsigned i)) as [|[|[|[|]]]]; inv H1; apply I.
       }
   f_equal.

    rewrite  (res_predicates.allp_jam_split2 _ _ _
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
                    [Byte b0; Byte b1; Byte b2] Undef)) sh loc)
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
                    [Byte b0; Byte b1] Undef)) sh loc)
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - (2+Ptrofs.unsigned i)))
                    [Byte b2] Undef)) sh loc)
           (adr_range_dec (b, Ptrofs.unsigned i) 3)
           (adr_range_dec (b, Ptrofs.unsigned i) 2)
           (adr_range_dec (b, 2 + Ptrofs.unsigned i) 1)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
           [Byte b0; Byte b1; Byte b2] Undef)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
           [Byte b0; Byte b1] Undef)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - (2+Ptrofs.unsigned i)))
           [Byte b2] Undef)).
    2:{ forget (Ptrofs.unsigned i) as j. clear.
         split; intros [b1 z1]. simpl. intuition rep_lia.
         simpl. intuition rep_lia.
       }
    2:{ intros. destruct l; destruct H; subst. f_equal. f_equal.
          rewrite (app_nth1 [Byte b0; Byte b1] [Byte b2]); auto.
        simpl. rep_lia.
       }
  2:{ intros. f_equal. f_equal.
       destruct l; destruct H. subst b4. simpl snd.
       assert (z = 2 + Ptrofs.unsigned i) by lia. subst z.
        rewrite Z.sub_diag.
        replace (2 + Ptrofs.unsigned i - Ptrofs.unsigned i) with 2 by lia.
          reflexivity.
      }
   2:{ intros. left. destruct H0. hnf in H0. rewrite H0 in H1 . clear H0.
        destruct l, H. subst. simpl snd in *.
        assert (Z.to_nat (z - Ptrofs.unsigned i) < 3)%nat by rep_lia.
        clear - H1. destruct (Z.to_nat (z - Ptrofs.unsigned i)) as [|[|[|]]]; inv H1; apply I.
       }

   f_equal.

    rewrite  (res_predicates.allp_jam_split2 _ _ _
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
                    [Byte b0; Byte b1] Undef)) sh loc)
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
                    [Byte b0] Undef)) sh loc)
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - (1+Ptrofs.unsigned i)))
                    [Byte b1] Undef)) sh loc)
           (adr_range_dec (b, Ptrofs.unsigned i) 2)
           (adr_range_dec (b, Ptrofs.unsigned i) 1)
           (adr_range_dec (b, 1 + Ptrofs.unsigned i) 1)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
           [Byte b0; Byte b1] Undef)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
           [Byte b0] Undef)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - (1+Ptrofs.unsigned i)))
           [Byte b1] Undef)).
    2:{ forget (Ptrofs.unsigned i) as j. clear.
         split; intros [b1 z1]. simpl. intuition rep_lia.
         simpl. intuition rep_lia.
       }
    2:{ intros. destruct l; destruct H; subst. f_equal. f_equal.
          rewrite (app_nth1 [Byte b0] [Byte b1]); auto.
        simpl. rep_lia.
       }
  2:{ intros. f_equal. f_equal.
       destruct l; destruct H. subst b4. simpl snd.
       assert (z = 1 + Ptrofs.unsigned i) by lia. subst z.
        rewrite Z.sub_diag.
        replace (1 + Ptrofs.unsigned i - Ptrofs.unsigned i) with 1 by lia.
          reflexivity.
      }
   2:{ intros. left. destruct H0. hnf in H0. rewrite H0 in H1 . clear H0.
        destruct l, H. subst. simpl snd in *.
        assert (Z.to_nat (z - Ptrofs.unsigned i) < 2)%nat by rep_lia.
        clear - H1. destruct (Z.to_nat (z - Ptrofs.unsigned i)) as [|[|[|]]]; inv H1; apply I.
       }
   f_equal.
Qed.

Import normalize.

Lemma address_mapsto_4bytes:
 forall
    (AP: Archi.ptr64 = true)  (* Perhaps this premise could be eliminated. *)
   (sh : Share.t)
    (b0 b1 b2 b3 : byte)
    (b : block)
    (i : ptrofs)
    (SZ : Ptrofs.unsigned i + 4 < Ptrofs.modulus)
    (AL : (4 | Ptrofs.unsigned i))
    (r : readable_share sh),
 predicates_sl.sepcon
  (predicates_sl.sepcon
     (predicates_sl.sepcon
        (res_predicates.address_mapsto Mint8unsigned
           (Vubyte b0) sh (b, Ptrofs.unsigned i))
        (res_predicates.address_mapsto Mint8unsigned
           (Vubyte b1) sh
           (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 1)))))
     (res_predicates.address_mapsto Mint8unsigned
        (Vubyte b2) sh (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 2)))))
  (res_predicates.address_mapsto Mint8unsigned (Vubyte b3) sh
     (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 3)))) =
res_predicates.address_mapsto Mint32
  (Vint (Int.repr (decode_int [b0; b1; b2; b3]))) sh
  (b, Ptrofs.unsigned i).
Proof.
intros.
      unfold res_predicates.address_mapsto. rewrite <- !exp_equiv.
      apply predicates_hered.pred_ext.
  - repeat change (exp ?A) with (predicates_hered.exp A).
      normalize.normalize.
      intros bl3 [A3 [B3 _]] bl2 bl1 bl0.
      normalize.normalize.
      destruct H as [A2 [ B2 _]].
      destruct H0 as [A1 [ B1 _]].
      destruct H1 as [A0 [ B0 _]].
    destruct bl0 as [ | c0 [|]]; inv A0; inv B0.
    destruct bl1 as [ | c1 [|]]; inv A1; inv B1.
    destruct bl2 as [ | c2 [|]]; inv A2; inv B2.
    destruct bl3 as [ | c3 [|]]; inv A3; inv B3.
     destruct c0; try discriminate H0.
     destruct c1; try discriminate H1.
     destruct c2; try discriminate H2.
     destruct c3; try discriminate H3.
   apply decode_val_Vubyte_inj in H0,H1,H2,H3. subst.
   apply (predicates_hered.exp_right [Byte b0; Byte b1; Byte b2; Byte b3]).
     rewrite predicates_hered.prop_true_andp.
      2:{ split3. reflexivity. reflexivity. apply AL. }
  match goal with |- predicates_hered.derives ?A ?B =>
        assert (EQ: A=B); [ | rewrite EQ; apply predicates_hered.derives_refl]
    end.
  apply address_mapsto_4bytes_aux; auto.

 -
  repeat change (exp ?A) with (predicates_hered.exp A).
      normalize.normalize.
  intros bl [? [? ?]]. simpl snd in H1.
      destruct bl as [|c0 [| c1 [| c2 [| c3 [|]]]]]; inv H.
       unfold decode_val, proj_bytes in H0. rewrite AP in H0. clear AP.
       destruct c0; try discriminate H0.
       destruct c1; try discriminate H0.
       destruct c2; try discriminate H0.
       destruct c3; try discriminate H0.
       apply Vint_inj in H0.
       pose proof (decode_int_range [b0;b1;b2;b3]).
       pose proof (decode_int_range [i0;i1;i2;i3]).
       change (two_p _) with Int.modulus in H,H2.
       apply repr_inj_unsigned in H0; try rep_lia.
        apply decode_int_inj in H0.
      clear H H2. inv H0.
     apply predicates_hered.exp_right with [Byte b3].
      normalize.normalize.
     apply predicates_hered.exp_right with [Byte b2].
      normalize.normalize.
     apply predicates_hered.exp_right with [Byte b1].
      normalize.normalize.
     apply predicates_hered.exp_right with [Byte b0].
     rewrite !predicates_hered.prop_true_andp by
     (split3; [ reflexivity |  | apply Z.divide_1_l  ];
     unfold decode_val, Vubyte; simpl; f_equal;
     rewrite decode_int_single;
     apply zero_ext_inrange; change (two_p _ - 1) with 255;
     rewrite Int.unsigned_repr by rep_lia; rep_lia).
  match goal with |- predicates_hered.derives ?A ?B =>
        assert (EQ: B=A); [ | rewrite EQ; apply predicates_hered.derives_refl]
    end.
  apply address_mapsto_4bytes_aux; auto.
  reflexivity.
Qed.

Lemma tc_val_Vubyte: forall b, tc_val tuchar (Vubyte b).
Proof.
intros; red.
simpl. rewrite Int.unsigned_repr by rep_lia.
rep_lia.
Qed.

Lemma nonlock_permission_4bytes:
 forall (sh : Share.t)
     (b : block) (i : ptrofs)
     (SZ : Ptrofs.unsigned i + 4 < Ptrofs.modulus),
(res_predicates.nonlock_permission_bytes sh (b, Ptrofs.unsigned i) 1
   * res_predicates.nonlock_permission_bytes sh
       (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 1))) 1
   * res_predicates.nonlock_permission_bytes sh
       (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 2))) 1
   * res_predicates.nonlock_permission_bytes sh
       (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 3))) 1)%logic =
res_predicates.nonlock_permission_bytes sh (b, Ptrofs.unsigned i) 4.
Proof.
intros.
 repeat   match goal with |- context [Ptrofs.add i (Ptrofs.repr ?A)] =>
    replace (Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr A)))
    with (A + Ptrofs.unsigned i)
    by (unfold Ptrofs.add; rewrite (Ptrofs.unsigned_repr (Z.pos _)) by rep_lia;
        rewrite Ptrofs.unsigned_repr by rep_lia; rep_lia)
   end.
 rewrite (res_predicates.nonlock_permission_bytes_split2 3 1 4 sh) by lia.
 rewrite (res_predicates.nonlock_permission_bytes_split2 2 1 3 sh) by lia.
 rewrite (res_predicates.nonlock_permission_bytes_split2 1 1 2 sh) by lia.
 repeat change (predicates_sl.sepcon ?A ?B) with (A * B)%logic.
 rewrite !(Z.add_comm (Ptrofs.unsigned i)).
 f_equal.
Qed.

(* The main result: 4 consecutive bytes can be interpreted as a single int *)
Lemma data_at_int_bytes:
  forall
    (AP: Archi.ptr64 = true)  (* Perhaps this premise could be eliminated. *)
  sh
   (b0 b1 b2 b3 : byte) p,
  field_compatible tuint [] p  ->
  (data_at sh tuchar (Vubyte b0) p *
  data_at sh tuchar (Vubyte b1) (offset_val 1 p) *
  data_at sh tuchar (Vubyte b2) (offset_val 2 p) *
  data_at sh tuchar (Vubyte b3) (offset_val 3 p))%logic =
  data_at sh tuint (Vint (Int.repr (decode_int [b0;b1;b2;b3]))) p.
Proof.
  intros AP sh b0 b1 b2 b3 p. unfold data_at. unfold field_at.
  intro.
  rewrite !prop_true_andp by auto with field_compatible.
 destruct H as [H0 [_ [SZ [AL _]]]]. red in SZ. simpl sizeof in SZ.
   destruct p; inversion H0. clear H0.
 assert (4 | Ptrofs.unsigned i)
   by (eapply align_compatible_rec_by_value_inv in AL; [ | reflexivity]; assumption).
 clear AL.
 unfold at_offset.
 rewrite !offset_offset_val. rewrite !Z.add_0_r.
 simpl offset_val. rewrite !ptrofs_add_repr_0_r.
 rewrite !data_at_rec_eq. simpl.
 change (unfold_reptype ?x) with x.
 unfold mapsto.
 simpl access_mode; simpl type_is_volatile; cbv iota.
 rewrite !(prop_true_andp _ _ (tc_val_Vubyte _)).
 rewrite !(prop_false_andp (_ = _)) by (intro Hx; inv Hx).
 rewrite !(prop_true_andp (tc_val tuint _)) by (apply Logic.I).
 rewrite ?prop_and_mpred.
 rewrite ?(prop_true_andp _ _ (tc_val_tc_val' _ _ (tc_val_Vubyte _))).
 rewrite !(prop_true_andp (tc_val' tuint _)) by (apply tc_val_tc_val'; apply Logic.I).
 rewrite ?(prop_true_andp _ _ (Z.divide_1_l _)).
 rewrite !orp_FF.
 rewrite (prop_true_andp (_ | _)) by apply H.
 if_tac.
- apply address_mapsto_4bytes; auto.
- apply nonlock_permission_4bytes; auto.
Qed.

(** Convert between 2 bytes and short *)

Lemma address_mapsto_2bytes_aux:
 forall (sh : Share.t)
   (b0 b1 b2 b3 : byte)
   (b : block) (i : ptrofs)
   (SZ : Ptrofs.unsigned i + 2 < Ptrofs.modulus)
   (r : readable_share sh),
predicates_sl.sepcon
     (predicates_hered.allp
        (res_predicates.jam (adr_range_dec (b, Ptrofs.unsigned i) (size_chunk Mint8unsigned))
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - snd (b, Ptrofs.unsigned i))) [Byte b0] Undef)) sh loc)
           res_predicates.noat))
     (predicates_hered.allp
        (res_predicates.jam
           (adr_range_dec (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 1))) (size_chunk Mint8unsigned))
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - snd (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 1)))))
                    [Byte b1] Undef)) sh loc) res_predicates.noat)) =
 predicates_hered.allp
     (res_predicates.jam (adr_range_dec (b, Ptrofs.unsigned i) (size_chunk Mint16unsigned))
        (fun loc : address =>
         res_predicates.yesat compcert_rmaps.RML.R.NoneP
           (compcert_rmaps.VAL
              (nth (Z.to_nat (snd loc - snd (b, Ptrofs.unsigned i))) [Byte b0; Byte b1] Undef)) sh loc)
    res_predicates.noat).
Proof.
intros. simpl snd. simpl size_chunk.
 repeat   match goal with |- context [Ptrofs.add i (Ptrofs.repr ?A)] =>
    replace (Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr A)))
    with (A + Ptrofs.unsigned i)
    by (unfold Ptrofs.add; rewrite (Ptrofs.unsigned_repr (Z.pos _)) by rep_lia;
        rewrite Ptrofs.unsigned_repr by rep_lia; rep_lia)
   end.
    rewrite  (res_predicates.allp_jam_split2 _ _ _
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
                    [Byte b0; Byte b1] Undef)) sh loc)
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
                    [Byte b0] Undef)) sh loc)
           (fun loc : address =>
            res_predicates.yesat compcert_rmaps.RML.R.NoneP
              (compcert_rmaps.VAL
                 (nth (Z.to_nat (snd loc - (1+Ptrofs.unsigned i)))
                    [Byte b1] Undef)) sh loc)
           (adr_range_dec (b, Ptrofs.unsigned i) 2)
           (adr_range_dec (b, Ptrofs.unsigned i) 1)
           (adr_range_dec (b, 1 + Ptrofs.unsigned i) 1)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
           [Byte b0; Byte b1] Undef)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - Ptrofs.unsigned i))
           [Byte b0] Undef)).
   2: eexists;
    apply (res_predicates.is_resource_pred_YES_VAL' sh
     (fun loc => nth (Z.to_nat (snd loc - (1+Ptrofs.unsigned i)))
           [Byte b1] Undef)).
    2:{ forget (Ptrofs.unsigned i) as j. clear.
         split; intros [b1 z1]. simpl. intuition rep_lia.
         simpl. intuition rep_lia.
       }
    2:{ intros. destruct l; destruct H; subst. f_equal. f_equal.
          rewrite (app_nth1 [Byte b0] [Byte b1]); auto.
        simpl. rep_lia.
       }
    2:{ intros. f_equal. f_equal.
       destruct l; destruct H. subst b4. simpl snd.
       assert (z = 1 + Ptrofs.unsigned i) by lia. subst z.
        rewrite Z.sub_diag.
        replace (1 + Ptrofs.unsigned i - Ptrofs.unsigned i) with 1 by lia.
          reflexivity.
      }
    2:{ intros. left. destruct H0. hnf in H0. rewrite H0 in H1 . clear H0.
        destruct l, H. subst. simpl snd in *.
        assert (Z.to_nat (z - Ptrofs.unsigned i) < 2)%nat by rep_lia.
        clear - H1. destruct (Z.to_nat (z - Ptrofs.unsigned i)) as [|[|[|]]]; inv H1; apply I.
       }
   f_equal.
Qed.

Lemma zero_ext_16: forall z,
  0 <= z < 65536 ->
  Int.zero_ext 16 (Int.repr z) = Int.repr z.
Proof.
  intros. unfold Int.zero_ext. f_equal.
  rewrite Zbits.Zzero_ext_mod by rep_lia.
  replace (two_p 16) with (65536) by reflexivity.
  rewrite Zmod_small; rewrite Int.unsigned_repr; rep_lia.
Qed.

Lemma address_mapsto_2bytes:
 forall (sh : Share.t)
    (b0 b1 : byte)
    (b : block)
    (i : ptrofs)
    (SZ : Ptrofs.unsigned i + 2 < Ptrofs.modulus)
    (AL : (2 | Ptrofs.unsigned i))
    (r : readable_share sh),
predicates_sl.sepcon (res_predicates.address_mapsto Mint8unsigned (Vubyte b0) sh (b, Ptrofs.unsigned i))
  (res_predicates.address_mapsto Mint8unsigned (Vubyte b1) sh
     (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 1)))) = res_predicates.address_mapsto Mint16unsigned
                                                              (Vint (Int.repr (decode_int [b0; b1]))) sh
                                                              (b, Ptrofs.unsigned i).
Proof.
  intros. unfold res_predicates.address_mapsto. rewrite <- !exp_equiv.
  apply predicates_hered.pred_ext.
  - repeat change (exp ?A) with (predicates_hered.exp A).
    normalize.normalize.
    intros bl1 [A1 [B1 _]] bl0.
    normalize.normalize.
    destruct H as [A0 [ B0 _]].
    destruct bl0 as [ | c0 [|]]; inv A0; inv B0.
    destruct bl1 as [ | c1 [|]]; inv A1; inv B1.
    destruct c0; try discriminate.
    destruct c1; try discriminate.
    apply decode_val_Vubyte_inj in H0,H1. subst.
    apply (predicates_hered.exp_right [Byte b0; Byte b1]).
    rewrite predicates_hered.prop_true_andp.
    2:{ split3. reflexivity. unfold decode_val. simpl.
        f_equal. apply zero_ext_16.
        pose proof (decode_int_range [b0; b1]). simpl in H.
        assert (two_power_pos 16 = 65536) by reflexivity. lia. apply AL.
      }
  match goal with |- predicates_hered.derives ?A ?B =>
        assert (EQ: A=B); [ | rewrite EQ; apply predicates_hered.derives_refl]
    end.
  apply address_mapsto_2bytes_aux; auto.
 - repeat change (exp ?A) with (predicates_hered.exp A).
   normalize.normalize.
   intros bl [? [? ?]].
    simpl snd in H1.
   destruct bl as [|c0 [| c1 [| c2 [| c3 [|]]]]]; inv H.
   unfold decode_val, proj_bytes in H0.
   destruct c0; try solve [destruct Archi.ptr64 eqn:AP; discriminate].
   destruct c1; try solve [destruct Archi.ptr64 eqn:AP; discriminate].
   apply Vint_inj in H0.
   pose proof (decode_int_range [b0;b1]).
   pose proof (decode_int_range [i0;i1]).
   change (two_p _) with 65536 in H,H2.
   rewrite zero_ext_16 in H0 by lia.
   apply repr_inj_unsigned in H0; try rep_lia.
    apply decode_int_inj in H0.
   clear H H2. inv H0.
  apply predicates_hered.exp_right with [Byte b1].
  normalize.normalize.
  apply predicates_hered.exp_right with [Byte b0].
  rewrite !predicates_hered.prop_true_andp by
 (split3; [ reflexivity |  | apply Z.divide_1_l  ];
 unfold decode_val, Vubyte; simpl; f_equal;
 rewrite decode_int_single;
 apply zero_ext_inrange; change (two_p _ - 1) with 255;
 rewrite Int.unsigned_repr by rep_lia; rep_lia).
  match goal with |- predicates_hered.derives ?A ?B =>
        assert (EQ: B=A); [ | rewrite EQ; apply predicates_hered.derives_refl]
    end.
  apply address_mapsto_2bytes_aux; auto.
  reflexivity.
Qed.

Lemma nonlock_permission_2bytes:
 forall (sh : Share.t)
     (b : block) (i : ptrofs)
     (SZ : Ptrofs.unsigned i + 2 < Ptrofs.modulus),
(res_predicates.nonlock_permission_bytes sh (b, Ptrofs.unsigned i) 1
   * res_predicates.nonlock_permission_bytes sh (b, Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr 1))) 1)%logic =
res_predicates.nonlock_permission_bytes sh (b, Ptrofs.unsigned i) 2.
Proof.
intros.
 repeat   match goal with |- context [Ptrofs.add i (Ptrofs.repr ?A)] =>
    replace (Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr A)))
    with (A + Ptrofs.unsigned i)
    by (unfold Ptrofs.add; rewrite (Ptrofs.unsigned_repr (Z.pos _)) by rep_lia;
        rewrite Ptrofs.unsigned_repr by rep_lia; rep_lia)
   end.
 rewrite (res_predicates.nonlock_permission_bytes_split2 1 1 2 sh) by lia.
 repeat change (predicates_sl.sepcon ?A ?B) with (A * B)%logic.
 rewrite !(Z.add_comm (Ptrofs.unsigned i)).
 f_equal.
Qed.

Lemma tc_val_short: forall (b0 b1 : byte),
  tc_val tushort (Vint (Int.repr (decode_int [b0; b1]))).
Proof.
  intros. simpl. pose proof (decode_int_range [b0; b1]).
  simpl in H. assert (two_power_pos 16 = 65536) by reflexivity.
  rewrite Int.unsigned_repr; rep_lia.
Qed.

Lemma prop_true_eq: forall  {A : Type} {ND : NatDed A} (P : Prop),
  P ->
  !! P = !! True.
Proof.
  intros. apply ND_prop_ext. split; auto.
Qed.

(* The main result: 2 consecutive bytes can be interpreted as a single short *)
Lemma data_at_short_bytes: forall sh
  (b0 b1: byte) p,
  field_compatible tushort [] p ->
  (data_at sh tuchar (Vubyte b0) p *
  data_at sh tuchar (Vubyte b1) (offset_val 1 p))%logic =
  data_at sh tushort (Vint (Int.repr (decode_int [b0; b1]))) p.
Proof.
   intros sh b0 b1 p. unfold data_at. unfold field_at. normalize.
    rewrite !(prop_true_andp _ _ H).
  assert (H': field_compatible tuchar [] p). {
    destruct H as [? [? [? [? ?]]]].
    split3; auto. destruct p; try contradiction.
    red in H1,H2,H3. split3; auto.
   red; simpl sizeof in *. lia.
   red. eapply align_compatible_rec_by_value; [reflexivity | ].
   apply Z.divide_1_l.
  }
  assert (H'': field_compatible tuchar [] (offset_val 1 p)). {
    unfold offset_val.
    destruct H as [? [? [? [? ?]]]].
    split3; auto. destruct p; try contradiction. apply I.
    red in H1,H2,H3.
    unfold Ptrofs.add. rewrite Ptrofs.unsigned_repr by rep_lia.
    destruct p; try contradiction.
   simpl in H1.
    split3; auto.
     red; simpl sizeof in *. rewrite Ptrofs.unsigned_repr by rep_lia. rep_lia.
   red. eapply align_compatible_rec_by_value; [reflexivity | ].
   apply Z.divide_1_l.
  }
   rewrite (prop_true_andp _ _ H').
   rewrite (prop_true_andp _ _ H'').
   simpl. rewrite !data_at_rec_eq. simpl.
    unfold at_offset. normalize. change (unfold_reptype ?x) with x.
    assert (isptr p) by apply H.
    destruct p; inversion H0. clear H0.
    unfold mapsto. rewrite (prop_true_eq _ (tc_val_short b0 b1)). simpl.
    destruct H as [_ [_ [SZ [AL _]]]]. red in SZ. simpl sizeof in SZ.
    apply align_compatible_rec_by_value_inv with (ch := Mint16unsigned) in AL; auto.
    simpl in AL.
    rewrite !(prop_true_andp _ _ Logic.I).
    rewrite !(prop_false_andp ( _ = Vundef)) by (intro Hx; inv  Hx).
    rewrite !orp_FF.
    rewrite !(prop_true_andp (_ /\ _))
   by (split; [apply (tc_val_tc_val' _ _ (tc_val_Vubyte _)) | apply Z.divide_1_l]).
   destruct (readable_share_dec sh); simpl; normalize.
    + rewrite !Int.unsigned_repr by rep_lia.
      rewrite !(prop_true_andp (Byte.unsigned _ <= _)) by rep_lia.
   repeat change (?A * ?B)%logic with (predicates_sl.sepcon A B).
   rewrite ?ptrofs_add_repr_0_r.
   apply address_mapsto_2bytes; auto.

   +
   rewrite ?ptrofs_add_repr_0_r.
       rewrite !prop_true_andp.
      2 : split; auto; hnf; intros; apply tc_val_short.
      apply nonlock_permission_2bytes; auto.
Qed.

End DataAtNumeric.

Lemma field_at_values_cohere {cs:compspecs}:
  forall sh1 sh2 t gfs
            (v1 v2 : reptype (nested_field_type t gfs))
             (p: val),
       value_defined (nested_field_type t gfs) v1 ->
       value_defined (nested_field_type t gfs) v2 ->
    readable_share sh1 -> readable_share sh2 ->
   field_at sh1 t gfs v1 p * field_at sh2 t gfs v2 p |-- !!(v1=v2).
Proof. intros.
  unfold field_at, at_offset; Intros.
  destruct H3 as [? _]. destruct p; try contradiction.
  apply data_at_rec_values_cohere; auto.
Qed.

Lemma data_at_values_cohere {cs:compspecs}:
  forall sh1 sh2 t
            (v1 v2 : reptype t)
             (p: val),
       value_defined t v1 ->
       value_defined t v2 ->
    readable_share sh1 -> readable_share sh2 ->
   data_at sh1 t v1 p * data_at sh2 t v2 p |-- !!(v1=v2).
Proof. intros.
  apply field_at_values_cohere; auto.
Qed.


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.EnumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.Narcissus.BinLib.Core
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Common.ComposeCheckSum
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Automation.SolverOpt
        Fiat.Narcissus.Formats.FixListOpt
        Fiat.Narcissus.Stores.EmptyStore
        Fiat.Narcissus.Formats.WordOpt
        Fiat.Narcissus.Formats.Bool
        Fiat.Narcissus.Formats.NatOpt
        Fiat.Narcissus.Formats.Vector
        Fiat.Narcissus.Formats.EnumOpt
        Fiat.Narcissus.Formats.SumTypeOpt
        Fiat.Narcissus.Formats.IPChecksum.

Require Import Bedrock.Word.

Import Vectors.VectorDef.VectorNotations.
Open Scope string_scope.
Open Scope Tuple_scope.

Definition InjectEnum {n A}
           (gallina_constructors: VectorDef.t A n)
           (enum_member: Fin.t n) : A :=
  VectorDef.nth gallina_constructors enum_member.
  Require Import IPv4Header.

Definition MakeDecoder {A}
           (impl: ByteString -> unit -> option (A * ByteString * unit))
           (bs: ByteString) : option (A * ByteString) :=
  (* let bs := {| padding := 0; front := WO; paddingOK := zero_lt_eight; byteString := buffer |} in *)
  match impl bs () with
  | Some (pkt, bs, _) => Some (pkt, bs)
  | None => None
  end.

Section FormatWord.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  (* Extracting words as Int64 prevents us from recursing on them directly *)

  Fixpoint encode_word'_recurse_on_size (sz : nat) (w : word sz) (b' : B) {struct sz} : B.
  Proof.
    destruct sz.
    - apply b'.
    - apply (enqueue_opt (whd w) (encode_word'_recurse_on_size sz (wtl w) b')).
  Defined.

  Lemma format'_on_size_correct :
    forall sz w b', encode_word' sz w b' = encode_word'_recurse_on_size sz w b'.
  Proof.
    induction sz; dependent destruction w; intros; simpl.
    - reflexivity.
    - rewrite IHsz; reflexivity.
  Qed.
End FormatWord.

Section Ethernet.
  Require Import EthernetHeader.

  Inductive fiat_ethernet_type := ARP | IP | RARP.

  Definition fiat_ethernet_decode packet_length := MakeDecoder (fst (frame_decoder packet_length)).

  Definition List_of_vector {A n} (v: Vector.t A n) : list A :=
    Vector.fold_right List.cons v nil.

  Definition fiat_ethernet_destruct_packet {A}
             (f: forall (Destination : list char)
                   (Source : list char)
                   (type : fiat_ethernet_type),
                 A)
             (packet: EthernetHeader) :=
    f  (List_of_vector packet!"Destination")
       (List_of_vector packet!"Source")
       (InjectEnum [ARP; IP; RARP] packet!"Type").
End Ethernet.

Section ARPv4.
  Require Import ARPPacket.

  Inductive fiat_arpv4_hardtype := Ethernet | IEEE802 | Chaos.
  Inductive fiat_arpv4_prottype := IPv4 | IPv6.
  Inductive fiat_arpv4_operation := Request | Reply | RARPRequest | RARPReply.

  Definition fiat_arpv4_decode := MakeDecoder (fst ARP_Packet_decoder).

  Definition fiat_arpv4_destruct_packet {A}
             (f: forall (HardType : fiat_arpv4_hardtype)
                   (ProtType : fiat_arpv4_prottype)
                   (Operation : fiat_arpv4_operation)
                   (SenderHardAddress : list char)
                   (SenderProtAddress : list char)
                   (TargetHardAddress : list char)
                   (TargetProtAddress : list char),
                 A)
             (packet: ARPPacket) : A :=
    f (InjectEnum [Ethernet; IEEE802; Chaos] packet!"HardType")
      (InjectEnum [IPv4; IPv6] packet!"ProtType")
      (InjectEnum [Request; Reply; RARPRequest; RARPReply] packet!"Operation")
      packet!"SenderHardAddress"
      packet!"SenderProtAddress"
      packet!"TargetHardAddress"
      packet!"TargetProtAddress".
End ARPv4.

Section IPv4.
  Require Import IPv4Header.

  Definition fiat_ipv4_decode := MakeDecoder IPv4_decoder_impl.

  Inductive fiat_ipv4_protocol :=
  | ICMP | TCP | UDP.

  Definition fiat_ipv4_protocol_to_enum (proto: fiat_ipv4_protocol) : EnumType ["ICMP"; "TCP"; "UDP"] :=
    match proto with
    | ICMP => ```"ICMP"
    | TCP => ```"TCP"
    | UDP => ```"UDP"
    end.

  Definition fiat_ipv4_construct_packet
             (TotalLength : (word 16))
             (ID : (word 16))
             (DF : bool)
             (MF : bool)
             (FragmentOffset : word 13)
             (TTL : char)
             (Protocol : fiat_ipv4_protocol)
             (SourceAddress : word 32)
             (DestAddress : word 32)
             (Options : list (word 32)) : IPv4_Packet :=
    <"TotalLength" :: TotalLength,
     "ID" :: ID,
     "DF" :: DF,
     "MF" :: MF,
     "FragmentOffset" :: FragmentOffset,
     "TTL" :: TTL,
     "Protocol" :: fiat_ipv4_protocol_to_enum Protocol,
     "SourceAddress" :: SourceAddress,
     "DestAddress" :: DestAddress,
     "Options" :: Options>.

  Definition fiat_ipv4_destruct_packet {A}
             (f: forall (TotalLength : (word 16))
                   (ID : (word 16))
                   (DF : bool)
                   (MF : bool)
                   (FragmentOffset : word 13)
                   (TTL : char)
                   (Protocol : fiat_ipv4_protocol)
                   (SourceAddress : word 32)
                   (DestAddress : word 32)
                   (Options : list (word 32)),
                 A)
              (packet : IPv4_Packet) : A :=
    f packet!"TotalLength"
      packet!"ID"
      packet!"DF"
      packet!"MF"
      packet!"FragmentOffset"
      packet!"TTL"
      (InjectEnum [ICMP; TCP; UDP] packet!"Protocol")
      packet!"SourceAddress"
      packet!"DestAddress"
      packet!"Options".
End IPv4.

Section TCP.
  Require Import TCP_Packet.

  Definition fiat_tcp_decode srcAddress dstAddress tcpLength :=
    MakeDecoder (TCP_Packet_decoder_impl srcAddress dstAddress tcpLength).

  Definition fiat_tcp_destruct_packet {A}
             (f: forall (SourcePort : word 16)
                   (DestPort : word 16)
                   (SeqNumber : word 32)
                   (AckNumber : word 32)
                   (NS : bool) (* ECN-nonce concealment protection flag *)
                   (CWR : bool) (* Congestion Window Reduced (CWR) flag *)
                   (ECE : bool) (* ECN-Echo flag *)
                   (ACK : bool) (* Acknowledgment field is significant flag *)
                   (PSH : bool) (* Push function flag *)
                   (RST : bool) (* Reset the connection flag *)
                   (SYN : bool) (* Synchronize sequence numbers flag *)
                   (FIN : bool) (* N srcAddress dstAddress udpLength o more data from sender flag*)
                   (WindowSize : word 16)
                   (UrgentPointer : option (word 16))
                   (Options : list (word 32))
                   (Payload : list char),
                 A)
             (packet: TCP_Packet) : A :=
    f packet!"SourcePort"
      packet!"DestPort"
      packet!"SeqNumber"
      packet!"AckNumber"
      packet!"NS"
      packet!"CWR"
      packet!"ECE"
      packet!"ACK"
      packet!"PSH"
      packet!"RST"
      packet!"SYN"
      packet!"FIN"
      packet!"WindowSize"
      packet!"UrgentPointer"
      packet!"Options"
      packet!"Payload".
End TCP.

Section UDP.
  Require Import UDP_Packet.

  Definition fiat_udp_decode srcAddress dstAddress udpLength :=
    MakeDecoder (UDP_Packet_decoder_impl srcAddress dstAddress udpLength).

  Definition fiat_udp_destruct_packet {A}
             (f: forall (SourcePort : word 16)
                   (DestPort : word 16)
                   (Payload : list char),
                 A)
             (packet: UDP_Packet) : A :=
    f packet!"SourcePort"
      packet!"DestPort"
      packet!"Payload".
End UDP.

Require Import ExtrOcamlBasic ExtrOcamlNatInt ExtrOcamlString.

Extract Inductive prod => "(*)"  [ "(,)" ].

(** * Inline a few functions *)
Extraction Inline DecodeBindOpt2.
Extraction Inline If_Opt_Then_Else.
Extraction Inline decode_nat decode_word decode_word'.

(** * Extract words as int64
      (Only works for word length < 64) *)
Extract Constant whd => "(fun _ w -> ((Int64.logand Int64.one w) = Int64.one))".
Extract Constant wtl => "(fun _ w -> (Int64.shift_right_logical w 1))".
Extract Constant wplus => "(fun _ w w' -> Int64.add w w')".
Extract Constant wmult => "(fun _ w w' -> Int64.mul w w')".
Extract Constant wminus => "(fun _ w w' -> Int64.max (Int64.zero) (Int64.sub w w'))".
Extract Constant weq => "(fun _ w w' -> w = w')".
Extract Constant weqb => "(fun _ w w' -> w = w')".
Extract Constant wlt => "(fun _ w w' -> w < w')".
Extract Constant wlt_dec => "(fun _ w w' -> w < w')".
Extract Constant wand => "(fun _ w w' -> Int64.logand w w')".
Extract Constant wor => "(fun _ w w' -> Int64.logor w w')".
Extract Constant wnot => "(fun _ w -> Int64.lognot w)".
Extract Constant wneg => "(fun _ w w' -> failwith ""Called Wneg"")".
Extract Constant combine => "(fun _ w w' -> failwith ""Using combine"")".
Extract Constant wordToNat => "(fun _ w -> Int64.to_int w)". (* Not ideal *)
Extract Constant natToWord => "(fun _ w -> Int64.of_int w)".
Extract Constant wzero => "(fun _ -> Int64.zero)".
Extract Constant wzero' => "(fun _ -> Int64.zero)".
Extract Constant wones => "(fun n -> Int64.sub (Int64.shift_left Int64.one n) Int64.one)".

Extract Constant SW_word => "(fun sz b n -> Int64.add (if b then Int64.shift_left Int64.one sz else Int64.zero) n)".

Extract Inductive Word.word =>
int64 ["Int64.zero" "(fun (b, _, w') -> Int64.add (if b then Int64.one else Int64.zero) (Int64.shift_left w' 1))"]
      "failwith ""Destructing an int64""".

(** * Don't recurse on int64 *)
Extract Constant encode_word' => "encode_word'_recurse_on_size".

(** * Special case of internet checksum *)
Extract Constant InternetChecksum.add_bytes_into_checksum =>
"(fun b_hi b_lo checksum ->
    let oneC_plus w w' =
      let sum = Int64.add w w' in
      let mask = Int64.of_int 65535 in
      (Int64.add (Int64.logand sum mask)
                 (Int64.shift_right_logical sum 16))
    in oneC_plus (Int64.logor (Int64.shift_left b_hi 8) b_lo) checksum)".

Extract Constant InternetChecksum.OneC_plus => "failwith ""Calling OneC_plus""".

(** Efficient bit strings *)

Extract Inductive ByteString =>
  "BitString.t"
    ["(fun _ -> failwith ""Constructing a ByteString"")"]
    "(fun _ _ -> failwith ""Destructing a ByteString"")".

Extract Constant ByteString_id => "(BitString.create ())".
Extract Constant ByteString_enqueue => "BitString.enqueue".
Extract Constant ByteString_dequeue => "BitString.dequeue".
Extract Constant length_ByteString => "BitString.bitlength".
Extract Constant ByteString_enqueue_ByteString => "BitString.append".

Extraction "Fiat4Mirage"
           fiat_ethernet_decode
           fiat_ethernet_destruct_packet
           fiat_arpv4_decode
           fiat_arpv4_destruct_packet
           fiat_ipv4_decode
           fiat_ipv4_destruct_packet
           fiat_tcp_decode
           fiat_tcp_destruct_packet
           fiat_udp_decode
           fiat_udp_destruct_packet
           encode_word'_recurse_on_size.