Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Cava.Util.List.
Require Import Cava.Util.Nat.
Require Import bedrock2.Array.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.Lift1Prop.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Scalars.
Require Import bedrock2.Semantics.
Require Import bedrock2.Syntax.
Require Import bedrock2.Loops.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import bedrock2.ZnWords.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Word.LittleEndianList.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Properties.
Require Import coqutil.Byte.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.Simp.
Require Import coqutil.Tactics.letexists.
Require Import Bedrock2Experiments.StateMachineSemantics.
Require Import Bedrock2Experiments.StateMachineProperties.
Require Import Bedrock2Experiments.Tactics.
Require Import Bedrock2Experiments.Word.
Require Import Bedrock2Experiments.WordProperties.
Require Import HmacSoftware.Constants.
Require Import HmacSoftware.HmacSemantics.
Require Import HmacSoftware.Hmac.
Require Import HmacSpec.SHA256.
Require Import Bedrock2Experiments.LibBase.AbsMMIOPropertiesUnique.
Require Import Bedrock2Experiments.LibBase.BitfieldProperties.
Require Import Bedrock2Experiments.LibBase.MMIOLabels.
Import Syntax.Coercions List.ListNotations HList.
Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope Z_scope.

(* TODO move to coqutil *)
Module byte.
  Lemma of_Z_unsigned: forall b,
    byte.of_Z (byte.unsigned b) = b.
  Proof.
    intros. eapply byte.unsigned_inj. rewrite byte.unsigned_of_Z.
    apply byte.wrap_unsigned.
  Qed.
End byte.

Module List.
  Lemma firstn_add{A: Type}(n m: nat)(l: list A):
    List.firstn (n + m) l = List.firstn n l ++ List.firstn m (List.skipn n l).
  Proof.
    rewrite <- (List.firstn_skipn n l) at 1.
    push_firstn; push_length; natsimpl.
    apply Nat.min_case_strong; intros; push_firstn; repeat (f_equal; try lia).
  Qed.
End List.

Lemma le_split_combine: forall bs n,
    n = List.length bs ->
    le_split n (le_combine bs) = bs.
Proof. intros. subst. apply split_le_combine. Qed.

Hint Rewrite @length_le_split : push_length.

(* bedrock2.ProgramLogic does cbv, which unfolds all constants *)
Ltac normalize_body_of_function f ::= Tactics.rdelta.rdelta f.

Section Proofs.
  Context {word: word.word 32} {mem: map.map word byte}
          {word_ok: word.ok word} {mem_ok: map.ok mem}.
  Context {timing: timing}.

  (* Plug in the right state machine parameters; typeclass inference struggles here *)
  Local Notation execution := (execution (M:=hmac_state_machine)).

  Infix "^+" := word.add  (at level 50, left associativity).
  Infix "^-" := word.sub  (at level 50, left associativity).
  Infix "^*" := word.mul  (at level 40, left associativity).
  Infix "^<<" := word.slu  (at level 37, left associativity).
  Infix "^>>" := word.sru  (at level 37, left associativity).
  Notation "/[ x ]" := (word.of_Z x) (* squeeze a Z into a word (beat it with a / to make it smaller) *)
                         (format "/[ x ]").
  Notation "\[ x ]" := (word.unsigned x)  (* \ is the open (removed) lid of the modulo box *)
                         (format "\[ x ]").    (* let a word fly into the large Z space *)

  Add Ring wring : (Properties.word.ring_theory (word := word))
        (preprocess [autorewrite with rew_word_morphism],
         morphism (Properties.word.ring_morph (word := word)),
         constants [Properties.word_cst]).

  Lemma invert_read_status_done_false: forall input n val s,
      read_step 4 (PROCESSING input n)
                /[TOP_EARLGREY_HMAC_BASE_ADDR + HMAC_INTR_STATE_REG_OFFSET] val s ->
      Z.testbit \[val ^>> /[HMAC_INTR_STATE_HMAC_DONE_BIT]] 0 = false ->
      s = PROCESSING input (n - 1) /\ 0 < n.
  Proof.
    intros.
    remember /[TOP_EARLGREY_HMAC_BASE_ADDR + HMAC_INTR_STATE_REG_OFFSET] as addr.
    inversion H; subst. 1: auto.
    exfalso. unfold HMAC_INTR_STATE_HMAC_DONE_BIT in *.
    rewrite word.unsigned_sru_nowrap in H0. 2: {
      rewrite word.unsigned_of_Z_0. reflexivity.
    }
    rewrite word.unsigned_of_Z_0 in H0.
    rewrite Z.shiftr_0_r in H0.
    congruence.
  Qed.

  Lemma invert_read_status_done_true: forall input n val s,
      read_step 4 (PROCESSING input n)
                /[TOP_EARLGREY_HMAC_BASE_ADDR + HMAC_INTR_STATE_REG_OFFSET] val s ->
      Z.testbit \[val ^>> /[HMAC_INTR_STATE_HMAC_DONE_BIT]] 0 = true ->
      s = IDLE (sha256 input)
               {| intr_enable := /[0];
                  hmac_done := true;
                  hmac_en := false;
                  sha_en := true;
                  swap_endian := true;
                  swap_digest := false |}.
  Proof.
    intros.
    remember /[TOP_EARLGREY_HMAC_BASE_ADDR + HMAC_INTR_STATE_REG_OFFSET] as addr.
    inversion H; subst. 2: reflexivity.
    exfalso. unfold HMAC_INTR_STATE_HMAC_DONE_BIT in *.
    rewrite word.unsigned_sru_nowrap in H0. 2: {
      rewrite word.unsigned_of_Z_0. reflexivity.
    }
    rewrite word.unsigned_of_Z_0 in H0.
    rewrite Z.shiftr_0_r in H0.
    congruence.
  Qed.

  Lemma invert_read_digest: forall b d i v s,
      0 <= \[i] < 8 ->
      read_step 4 (IDLE b d)
                (/[TOP_EARLGREY_HMAC_BASE_ADDR + HMAC_DIGEST_7_REG_OFFSET] ^- i ^* /[4]) v s ->
      s = IDLE b d /\ v = /[le_combine (List.firstn 4 (List.skipn (Z.to_nat \[i] * 4) b))].
  Proof.
    intros.
    remember (/[TOP_EARLGREY_HMAC_BASE_ADDR + HMAC_DIGEST_7_REG_OFFSET] ^- i ^* /[4]) as a.
    inversion H0. subst. split; [reflexivity|].
    f_equal. f_equal. f_equal. f_equal. ZnWords.
  Qed.

  (* not needed in this file directly, but needed at proof linking time to discharge
     assumption in AbsMMIOWritePropertiesUnique *)
  Lemma execution_unique (t : trace) s1 s2 :
    execution t s1 ->
    execution t s2 ->
    s1 = s2.
  Proof.
    eapply StateMachineProperties.execution_unique; intros;
      cbn [state_machine.is_initial_state state_machine.read_step state_machine.write_step
           hmac_state_machine] in *; simp.
    all: try match goal with
             | H: read_step _ _ _ _ _ |- _ => inversion H; subst; clear H
             | H: write_step _ _ _ _ _ |- _ => inversion H; subst; clear H
             end.
  Admitted.

  (* TODO move to bedrock2? *)
  Notation bytearray := (array (mem := mem) ptsto (word.of_Z 1)).
  Notation wordarray := (array (mem := mem) scalar32 (word.of_Z 4)).

  Axiom TODO: False.

  Lemma ptsto_aliasing_contradiction a b1 b2 (R: mem -> Prop) m
        (Hsep: (ptsto a b1 * ptsto a b2 * R)%sep m)
    : False.
  Proof.
    unfold sep in Hsep.
    unfold map.split, ptsto in *.
    simp.
    unfold map.disjoint in *.
    specialize (Hsepp1p0p1 a).
    rewrite !map.get_put_same in Hsepp1p0p1.
    eauto.
  Qed.

  (* Note: Often, we have a hypothesis `word.unsigned len = Z.of_nat (length l)`,
     from which word.unsigned_range gives us a bound that's even 1 tighter *)
  Lemma bytearray_max_length(a: word)(l: list byte)(R: mem -> Prop)(m: mem)
        (Hsep: (bytearray a l * R)%sep m)
    : Z.of_nat (List.length l) <= 2 ^ 32.
  Proof.
    remember (2 ^ 32) as B.
    assert (Z.of_nat (List.length l) <= B \/
            B < Z.of_nat (List.length l)) as C by lia.
    destruct C as [C | C]. 1: lia.
    exfalso.
    rewrite <- (List.firstn_nth_skipn _ (Z.to_nat B) l Byte.x00) in Hsep by lia.
    rewrite <- (List.firstn_nth_skipn _ 0 (List.firstn (Z.to_nat B) l) Byte.x00) in Hsep by length_hammer.
    autorewrite with listsimpl push_firstn in *.
    seprewrite_in (array_append ptsto) Hsep.
    seprewrite_in (array_append ptsto) Hsep.
    seprewrite_in (array_append ptsto) Hsep.
    seprewrite_in (array_cons ptsto) Hsep.
    seprewrite_in (array_cons ptsto) Hsep.
    eapply ptsto_aliasing_contradiction.
    use_sep_assumption.
    cancel.
    cancel_seps_at_indices 0%nat 0%nat. 1: reflexivity.
    cancel_seps_at_indices 1%nat 0%nat. 1:f_equal; push_length; ZnWords.
    ecancel_done.
  Qed.

  Lemma load_one_of_bytearray (addr addr': word) (values : list byte) R m
    (Hsep : sep (bytearray addr values) R m)
    : let n := Z.to_nat (word.unsigned (word.sub addr' addr)) in
      (n < List.length values)%nat ->
      Memory.load access_size.one m addr' =
      Some (word.of_Z (byte.unsigned (nth n values Byte.x00))).
  Proof.
    intros.
    rewrite <-(List.firstn_nth_skipn _ _ values Byte.x00 H) in Hsep.
    do 2 seprewrite_in (array_append ptsto) Hsep.
    seprewrite_in (array_cons ptsto) Hsep.
    seprewrite_in (array_nil ptsto) Hsep.
    autorewrite with push_length natsimpl in *.
    eapply load_one_of_sep.
    use_sep_assumption.
    cancel.
    cancel_seps_at_indices 0%nat 0%nat. {
      f_equal. ZnWords.
    }
    ecancel_done.
  Qed.

  Lemma isolate_scalar32_of_bytarray: forall (addr addr': word) values,
    let n := Z.to_nat (word.unsigned (word.sub addr' addr)) in
    (n + 4 <= Datatypes.length values)%nat ->
    iff1 (bytearray addr values)
         (bytearray addr (List.firstn n values) *
          scalar32 addr' (word.of_Z (le_combine (List.firstn 4 (List.skipn n values)))) *
          bytearray (word.add addr' (word.of_Z 4)) (List.skipn (n + 4) values))%sep.
  Proof.
    intros.
    rewrite <- (List.firstn_skipn n values) at 1.
    rewrite <- (List.firstn_skipn 4 (List.skipn n values)) at 1.
    do 2 rewrite (array_append ptsto).
    cancel.
    cancel_seps_at_indices 0%nat 0%nat. {
      unfold scalar32, truncated_word, truncated_scalar, littleendian, ptsto_bytes.ptsto_bytes.
      f_equal. 1: ZnWords.
      replace (bytes_per (width:=32) access_size.four)
        with (Datatypes.length (List.firstn 4 (List.skipn n values)))
        by (cbv [bytes_per]; length_hammer).
      rewrite word.unsigned_of_Z_nowrap. 2: {
        match goal with
        | |- context[le_combine ?x] =>
          pose proof (le_combine_bound x) as P
        end.
        autorewrite with push_length in P.
        rewrite min_l in P by ZnWords.
        exact P.
      }
      remember (List.firstn 4 (List.skipn n values)) as l.
      assert (List.length l = 4%nat) as HL by (subst; length_hammer).
      rewrite <- (le_split_combine _ 4) at 1. 2: {
        symmetry. exact HL.
      }
      destruct l as [|b0 l]. 1: discriminate HL.
      destruct l as [|b1 l]. 1: discriminate HL.
      destruct l as [|b2 l]. 1: discriminate HL.
      destruct l as [|b3 l]. 1: discriminate HL.
      destruct l as [|b4 l]. 2: discriminate HL.
      clear HL.
      reflexivity.
    }
    cancel_seps_at_indices 0%nat 0%nat. {
      f_equal.
      - push_length. ZnWords.
      - push_skipn. f_equal; lia.
    }
    ecancel_done.
  Qed.

  Lemma load_four_of_bytearray (addr addr': word) (values : list byte) R m
    (Hsep : sep (bytearray addr values) R m)
    : let n := Z.to_nat (word.unsigned (word.sub addr' addr)) in
      (n + 4 <= List.length values)%nat ->
      Memory.load access_size.four m addr' =
      Some (word.of_Z (le_combine (List.firstn 4 (List.skipn n values)))).
  Proof.
    intros.
    eapply load_four_of_sep_32bit. 1: reflexivity.
    seprewrite_in isolate_scalar32_of_bytarray Hsep. 1: subst n; eassumption.
    ecancel_assumption.
  Qed.

  Lemma store_four_to_bytearray (addr addr' v: word) (values : list byte) R m (post: mem -> Prop):
    sep (bytearray addr values) R m ->
    let n := Z.to_nat (word.unsigned (word.sub addr' addr)) in
    (n + 4 <= List.length values)%nat ->
    (forall m', sep (bytearray addr (List.upds values n (le_split 4 (word.unsigned v)))) R m' ->
               post m') ->
    exists m', Memory.store access_size.four m addr' v = Some m' /\ post m'.
  Proof.
    intros Hsep n HL HPost.
    eapply store_four_of_sep.
    - seprewrite_in isolate_scalar32_of_bytarray Hsep. 1: subst n; eassumption.
      ecancel_assumption.
    - clear dependent m. intros m Hsep. eapply HPost.
      SeparationLogic.seprewrite isolate_scalar32_of_bytarray. {
        rewrite List.upds_length. subst n. exact HL.
      }
      use_sep_assumption.
      cancel.
      unfold List.upds. change (Z.to_nat \[addr' ^- addr]) with n.
      pose proof (length_le_split 4 \[v]).
      cancel_seps_at_indices 0%nat 1%nat. {
        f_equal.
        repeat (listsimpl || push_skipn || push_firstn || push_length).
        rewrite le_combine_split.
        change (Z.of_nat 4 * 8) with 32.
        rewrite word.wrap_unsigned.
        rewrite word.of_Z_unsigned.
        reflexivity.
      }
      cancel_seps_at_indices 0%nat 0%nat. {
        f_equal.
        repeat (listsimpl || natsimpl || push_firstn || push_length).
        reflexivity.
      }
      cancel_seps_at_indices 0%nat 0%nat. {
        f_equal.
        rewrite length_le_split in *.
        repeat (listsimpl || natsimpl || push_skipn || push_firstn || push_length).
        f_equal; lia.
      }
      ecancel_done.
  Qed.

  Lemma Zlandb: forall (b1 b2: bool),
      Z.land (if b1 then 1 else 0) (if b2 then 1 else 0) = if (andb b1 b2) then 1 else 0.
  Proof. destruct b1; destruct b2; reflexivity. Qed.

  Lemma then1_else0_nonzero: forall b: bool,
      (if b then 1 else 0) <> 0 -> b = true.
  Proof. destruct b; congruence. Qed.

  Lemma then1_else0_zero: forall b: bool,
      (if b then 1 else 0) = 0 -> b = false.
  Proof. destruct b; congruence. Qed.

  Lemma Zland_ones_to_mod: forall a ones,
      ones = Z.ones (Z.log2_up ones) ->
      Z.land a ones = a mod 2 ^ (Z.log2_up ones).
  Proof.
    intros. rewrite <- Z.land_ones. 2: apply Z.log2_up_nonneg.
    f_equal. exact H.
  Qed.

  Lemma Zland_pow2_to_testbit: forall a pow2,
      pow2 = 2 ^ (Z.log2_up pow2) ->
      Z.land a pow2 = if Z.testbit a (Z.log2_up pow2) then pow2 else 0.
  Proof.
    intros.
    eapply Z.bits_inj'. intros.
    rewrite Z.land_spec.
    rewrite prove_Zeq_bitwise.testbit_if.
    rewrite H at 1.  rewrite H at 3.
    rewrite Z.pow2_bits_eqb by apply Z.log2_up_nonneg.
    rewrite Z.testbit_0_l.
    destr (Z.eqb (Z.log2_up pow2) n).
    + subst n. destruct (Z.testbit a (Z.log2_up pow2)); reflexivity.
    + rewrite Bool.andb_false_r. destr (Z.testbit a (Z.log2_up pow2)); reflexivity.
  Qed.

  Ltac simpl_conditional :=
    match goal with
    | H: _ /\ _ |- _ => destruct H
    | H: _ |- _ => rewrite Zlandb in H
    | H: word.eqb ?x ?y = true  |- _ => apply (word.eqb_true  x y) in H
    | H: word.eqb ?x ?y = false |- _ => apply (word.eqb_false x y) in H
    | H: andb ?b1 ?b2 = true |- _ => apply (Bool.andb_true_iff b1 b2) in H
    | H: andb ?b1 ?b2 = false |- _ => apply (Bool.andb_false_iff b1 b2) in H
    | H: orb ?b1 ?b2 = true |- _ => apply (Bool.orb_true_iff b1 b2) in H
    | H: orb ?b1 ?b2 = false |- _ => apply (Bool.orb_false_iff b1 b2) in H
    | H: _ |- _ => rewrite word.unsigned_and_nowrap in H
    | H: _ |- _ => rewrite word.unsigned_if in H
    | H: _ |- _ => rewrite word.unsigned_eqb in H
    | H: _ |- _ => rewrite word.unsigned_ltu in H
    | H: _ |- _ => rewrite word.unsigned_of_Z_small in H by
          (lazymatch goal with
           | |- _ <= ?x < 2 ^ _ =>
             lazymatch isZcst x with true => cbv; intuition discriminate end
           end)
    | H: _ |- _ => apply then1_else0_nonzero in H
    | H: _ |- _ => apply then1_else0_zero in H
    | H: Z.eqb _ _ = true |- _ => apply Z.eqb_eq in H
    | H: Z.eqb _ _ = false |- _ => apply Z.eqb_neq in H
    | H: Z.ltb _ _ = true |- _ => eapply Z.ltb_lt in H
    | H: Z.ltb _ _ = false |- _ => eapply Z.ltb_ge in H
    | H: context[Z.land ?a ?ones] |- _ =>
      lazymatch isZcst ones with true => idtac end;
      let m := eval cbv in (2 ^ Z.log2_up ones) in
      rewrite (Zland_ones_to_mod a ones eq_refl: _ = a mod m) in H
    | H: context[Z.land ?a ?pow2] |- _ =>
      let i := lazymatch isZcst pow2 with
               | true => eval cbv in (Z.log2_up pow2)
               | false => lazymatch pow2 with
                          | 2 ^ ?m => m
                          end
               end in
      rewrite (Zland_pow2_to_testbit a pow2 eq_refl:
                 Z.land a pow2 = if Z.testbit a i then pow2 else 0) in H
    | H: word.unsigned (if ?b then _ else _) = 0 |- _ => apply word.if_zero in H
    | H: word.unsigned (if ?b then _ else _) <> 0 |- _ => apply word.if_nonzero in H
    end.

  Ltac simpl_conditionals := repeat simpl_conditional.

  Global Instance spec_of_hmac_sha256_init : spec_of b2_hmac_sha256_init :=
    fun function_env =>
      forall tr m (R : mem -> Prop) (digest_buffer: list byte) (d: idle_data),
      R m ->
      execution tr (IDLE digest_buffer d) ->
      call function_env b2_hmac_sha256_init tr m []
        (fun tr' m' rets =>
            rets = [] /\ execution tr' (CONSUMING []) /\ R m').
  Lemma hmac_sha256_init_correct :
    program_logic_goal_for_function! b2_hmac_sha256_init.
  Proof.
    repeat straightline.
    straightline_call. 1: reflexivity. 1: eapply write_cfg. 1: eassumption.
    repeat straightline.
    straightline_call. 1: reflexivity. 1: eapply write_intr_enable. 1: eassumption.
    cbn [intr_enable hmac_done hmac_en sha_en swap_endian swap_digest] in *.
    repeat straightline.
    straightline_call. 1: reflexivity. 1: eapply write_intr_state. 1: eassumption.
    cbn [intr_enable hmac_done hmac_en sha_en swap_endian swap_digest] in *.
    repeat straightline.
    straightline_call.
    repeat straightline.
    straightline_call.
    repeat straightline.
    straightline_call.
    repeat straightline.
    straightline_call.
    repeat straightline.
    straightline_call. 1: reflexivity. 1: eapply write_cfg. 1: eassumption.
    repeat straightline.
    straightline_call.
    repeat straightline.
    cbn [intr_enable hmac_done hmac_en sha_en swap_endian swap_digest] in *.
    straightline_call. 1: reflexivity. 1: eapply write_hash_start. {
      (* bitfiddling *)
      case TODO.
    }
    { match goal with
      | H: execution ?t ?s1 |- execution ?t ?s2 => replace s2 with s1; [exact H|]
      end.
      f_equal. f_equal.
      (* bitfiddling *)
      all: case TODO.
    }
    repeat straightline.
    ssplit; eauto.
  Qed.

  Global Instance spec_of_hmac_sha256_update : spec_of b2_hmac_sha256_update :=
    fun function_env =>
      forall tr m (R : mem -> Prop) (previous_input new_input: list byte) data_addr len,
      word.unsigned len = Z.of_nat (length new_input) ->
      data_addr <> word.of_Z 0 ->
      (bytearray data_addr new_input * R)%sep m ->
      execution tr (CONSUMING previous_input) ->
      call function_env b2_hmac_sha256_update tr m [data_addr; len]
        (fun tr' m' rets =>
           rets = [word.of_Z Constants.kErrorOk] /\
           execution tr' (CONSUMING (previous_input ++ new_input)) /\
           (bytearray data_addr new_input * R)%sep m').

  Lemma hmac_sha256_update_correct :
    program_logic_goal_for_function! b2_hmac_sha256_update.
  Proof.
    repeat straightline.
    unfold1_cmd_goal; cbv beta match delta [cmd_body].
    repeat straightline.
    subst v.
    rewrite word.unsigned_if.
    rewrite word.eqb_ne by assumption.
    rewrite word.unsigned_of_Z_0.
    split; intros E. 1: exfalso; apply E; reflexivity.
    clear E.
    repeat straightline.
    set (data_aligned := word.of_Z (word.unsigned (word.add data_addr (word.of_Z 3)) / 4 * 4)).
    rename fifo_reg into fifo_reg0, len into len0.

    (* first while loop: *)
    eapply (while ["fifo_reg"; "data_sent"; "data"; "len"]
                  (fun measure t m fifo_reg data_sent data len =>
                     data_addr = data /\
                     fifo_reg = fifo_reg0 /\
                     data_sent ^+ /[measure] = data_aligned /\
                     0 <= measure < 4 /\
                     \[data_sent ^- data_addr] + \[len] = Z.of_nat (List.length new_input) /\
                     (bytearray data_addr new_input * R)%sep m /\
                     execution t (CONSUMING (previous_input ++
                        List.firstn (Z.to_nat \[data_sent ^- data_addr]) new_input)))
                  (Z.lt_wf 0)
                  \[data_aligned ^- data_addr]).
    1: repeat straightline.
    { (* invariant holds initially: *)
      loop_simpl.
      replace (Z.to_nat \[data_addr ^- data_addr]) with 0%nat by ZnWords.
      push_firstn; listsimpl.
      ssplit; try assumption; try ZnWords. }
    loop_simpl.
    intros measure t m0 fifo_reg data_sent data len. (* TODO derive names automatically *)
    repeat straightline.
    { (* if br is true, running first loop body again satisfies invariant *)
      subst br.
      simpl_conditionals.
      eexists. split. {
        repeat straightline.
        eexists. split.
        { eapply load_one_of_bytearray. 1: eassumption. ZnWords. }
        repeat straightline.
      }
      straightline_call.
      { cbv [state_machine.reg_addr hmac_state_machine id]. reflexivity. }
      2: eassumption.
      { eapply write_byte. 2: reflexivity.
        match goal with
        | |- context[byte.unsigned ?x] => pose proof (byte.unsigned_range x)
        end.
        ZnWords. }
      repeat straightline.
      cbv [Markers.unique Markers.split].
      eexists (measure - 1). ssplit; trivial; try ZnWords.
      subst a.
      eapply execution_step_write with (sz := 1%nat). 1: eassumption. 1: reflexivity.
      cbv [state_machine.write_step hmac_state_machine].
      replace (Z.to_nat \[data_sent ^- data]) with
              (S (Z.to_nat \[data_sent0 ^- data])) by ZnWords.
      rewrite <- (List.firstn_nth _ _ _ Byte.x00) by ZnWords.
      rewrite List.app_assoc.
      match goal with
      | |- context[byte.unsigned ?x] => pose proof (byte.unsigned_range x)
      end.
      eapply write_byte. 1: ZnWords.
      f_equal. f_equal.
      rewrite word.unsigned_of_Z_small by ZnWords.
      rewrite byte.of_Z_unsigned.
      reflexivity.
    }
    (* if br is false, code after first loop is correct: *)
    subst br.
    simpl_conditionals.
    match goal with
    | H: _ \/ _ |- _ => destruct H as [A | A]; simpl_conditionals
    end.
    { (* if the first loop was ended because len=0, the remaining two loops are skipped: *)
      eapply while_zero_iterations. {
        repeat straightline.
        subst v.
        rewrite word.unsigned_ltu.
        apply word.unsigned_inj.
        rewrite word.unsigned_if.
        destruct_one_match; ZnWords.
      }
      repeat straightline.
      eapply while_zero_iterations. {
        repeat straightline. ZnWords.
      }
      repeat straightline.
      ssplit. 1: reflexivity. 2: eassumption.
      match goal with
      | H: execution ?t ?s1 |- execution ?t ?s2 =>
        replace s2 with s1; [exact H|]
      end.
      f_equal. f_equal. push_firstn. reflexivity.
    }
    (* if the first loop was ended because `data_sent & 3 == 0`,
       we have to step through the remaining two loops as well: *)
    assert (data_sent = data_aligned) by ZnWords. subst data_sent.
    clear dependent tr.
    clear dependent measure.
    clear dependent m.
    match goal with
    | H: word.unsigned ?L = Z.of_nat (List.length new_input) |- _ =>
      pose proof (word.unsigned_range L) as LB;
      rewrite H in LB;
      clear dependent L
    end.
    rename data into data_addr, t into tr, len into len0.

    (* second while loop: *)
    eapply (while ["fifo_reg"; "data_sent"; "data"; "len"]
                  (fun measure t m fifo_reg data_sent data len =>
                     data_addr = data /\
                     fifo_reg = fifo_reg0 /\
                     measure = \[len] /\
                     \[data_sent] mod 4 = 0 /\
                     \[data_sent ^- data_addr] + \[len] = Z.of_nat (List.length new_input) /\
                     (bytearray data_addr new_input * R)%sep m /\
                     execution t (CONSUMING (previous_input ++
                        List.firstn (Z.to_nat \[data_sent ^- data_addr]) new_input)))
                  (Z.lt_wf 0)
                  \[len0]).
    1: repeat straightline.
    { (* invariant holds initially: *)
      loop_simpl.
      ssplit; try assumption; try ZnWords. }
    loop_simpl.
    intros measure t m fifo_reg data_sent data len. (* TODO derive names automatically *)
    repeat straightline.
    { (* if br is true, running first loop body again satisfies invariant *)
      subst br.
      simpl_conditionals.
      eexists. split. {
        repeat straightline.
        eexists. split.
        { eapply load_four_of_bytearray. 1: eassumption. ZnWords. }
        repeat straightline.
      }
      straightline_call.
      { cbv [state_machine.reg_addr hmac_state_machine id]. reflexivity. }
      2: eassumption.
      1: eapply write_word. 1: reflexivity.
      repeat straightline.
      cbv [Markers.unique Markers.split].
      eexists (measure - 4). ssplit; trivial; try ZnWords.
      subst a.
      eapply execution_step_write with (sz := 4%nat). 1: eassumption. 1: reflexivity.
      cbv [state_machine.write_step hmac_state_machine].
      eapply write_word. rewrite <- List.app_assoc. f_equal.
      subst data_sent.
      match goal with
      | |- context[le_combine ?x] =>
        pose proof (le_combine_bound x) as P
      end.
      autorewrite with push_length in P.
      rewrite min_l in P by ZnWords.
      rewrite word.unsigned_of_Z_small by ZnWords.
      rewrite le_split_combine. 2: {
        rewrite List.firstn_length. ZnWords.
      }
      replace (Z.to_nat \[data_sent0 ^+ /[4] ^- data])
        with (Z.to_nat \[data_sent0 ^- data] + 4)%nat by ZnWords.
      apply List.firstn_add.
    }
    (* if br is false, code after second loop is correct: *)
    subst br.
    simpl_conditionals.
    clear dependent tr.
    clear dependent m0.
    clear dependent len0.
    rename data_sent into data_aligned_last.
    rename data into data_addr, t into tr, len into len0.
    set (data_past_end := data_addr ^+ /[Z.of_nat (List.length new_input)]).

    (* third while loop: *)
    eapply (while ["fifo_reg"; "data_sent"; "data"; "len"]
                  (fun measure t m fifo_reg data_sent data len =>
                     data_addr = data /\
                     fifo_reg = fifo_reg0 /\
                     measure = \[len] /\
                     0 <= measure < 4 /\
                     \[data_sent ^- data_addr] + \[len] = Z.of_nat (List.length new_input) /\
                     (bytearray data_addr new_input * R)%sep m /\
                     execution t (CONSUMING (previous_input ++
                        List.firstn (Z.to_nat \[data_sent ^- data_addr]) new_input)))
                  (Z.lt_wf 0)
                  \[len0]).
    1: repeat straightline.
    { (* invariant holds initially: *)
      loop_simpl.
      ssplit; try assumption; try ZnWords. }
    loop_simpl.
    intros measure t m0 fifo_reg data_sent data len. (* TODO derive names automatically *)
    repeat straightline.
    { (* if break condition is true, running third loop body again satisfies invariant *)
      simpl_conditionals.
      eexists. split. {
        repeat straightline.
        eexists. split.
        { eapply load_one_of_bytearray. 1: eassumption. ZnWords. }
        repeat straightline.
      }
      straightline_call.
      { cbv [state_machine.reg_addr hmac_state_machine id]. reflexivity. }
      2: eassumption.
      { eapply write_byte. 2: reflexivity.
        match goal with
        | |- context[byte.unsigned ?x] => pose proof (byte.unsigned_range x)
        end.
        ZnWords. }
      repeat straightline.
      cbv [Markers.unique Markers.split].
      eexists (measure - 1). ssplit; trivial; try ZnWords.
      subst a.
      eapply execution_step_write with (sz := 1%nat). 1: eassumption. 1: reflexivity.
      cbv [state_machine.write_step hmac_state_machine].
      replace (Z.to_nat \[data_sent ^- data]) with
              (S (Z.to_nat \[data_sent0 ^- data])) by ZnWords.
      rewrite <- (List.firstn_nth _ _ _ Byte.x00) by ZnWords.
      rewrite List.app_assoc.
      match goal with
      | |- context[byte.unsigned ?x] => pose proof (byte.unsigned_range x)
      end.
      eapply write_byte. 1: ZnWords.
      f_equal. f_equal.
      rewrite word.unsigned_of_Z_small by ZnWords.
      rewrite byte.of_Z_unsigned.
      reflexivity.
    }
    (* if break condition is false, `result = kErrorOk` is run and now we have to prove
       the postcondition of the function: *)
    split; [reflexivity|].
    split; [|eassumption].
    match goal with
    | H: execution ?t ?s |- execution ?t ?s' => replace s' with s; [exact H|]
    end.
    push_firstn. reflexivity.
  Qed.

  Global Instance spec_of_hmac_sha256_final : spec_of b2_hmac_sha256_final :=
    fun function_env =>
      forall tr (m: mem) (R : mem -> Prop)
             (input digest_trash: list Byte.byte) (digest_addr: word),
      Z.of_nat (length digest_trash) = 32 ->
      digest_addr <> word.of_Z 0 ->
      (bytearray digest_addr digest_trash * R)%sep m ->
      execution tr (CONSUMING input) ->
      call function_env b2_hmac_sha256_final tr m [digest_addr]
        (fun tr' (m': mem) rets =>
           rets = [word.of_Z Constants.kErrorOk] /\
           execution tr' (IDLE (sha256 input) (* digest has been read, but still in device *)
                            {| hmac_done := false; (* done flag was already cleared by this function *)
                               intr_enable := word.of_Z 0;
                               hmac_en := false;
                               sha_en := true;
                               swap_endian := true;
                               swap_digest := false; |}) /\
           (* digest has been stored at correct memory location: *)
           (bytearray digest_addr (sha256 input) * R)%sep m').

  Lemma hmac_sha256_final_correct :
    program_logic_goal_for_function! b2_hmac_sha256_final.
  Proof.
    repeat straightline.
    assert (List.length (sha256 input) = 32)%nat by case TODO.
    unfold1_cmd_goal; cbv beta match delta [cmd_body].
    repeat straightline.
    subst v.
    rewrite word.unsigned_if.
    rewrite word.eqb_ne by assumption.
    rewrite word.unsigned_of_Z_0.
    split; intros E. 1: exfalso; apply E; reflexivity.
    clear E.
    repeat straightline.
    straightline_call.
    repeat straightline.
    straightline_call. 1: reflexivity. 1: eapply write_hash_process. 2: eassumption.
    { case TODO. (* bitfiddling *) }
    repeat straightline.
    subst done.

    (* first while loop *)
    eapply atleastonce with (variables := ["digest"; "reg"; "done"])
             (invariant := fun measure t m digest reg done =>
               digest = digest_addr /\
               execution t (PROCESSING input measure) /\
               (bytearray digest_addr digest_trash ⋆ R)%sep m).
    { repeat straightline. }
    { eapply (Z.lt_wf 0). }
    { (* if condition initially is false, that's a contradiction, so we don't need to prove post: *)
      repeat straightline. subst br. simpl_conditionals. exfalso. eauto. }
    { (* invariant holds initially *)
      loop_simpl. eauto. }
    loop_simpl.
    (* step through first loop body: *)
    repeat straightline.
    straightline_call. 1: reflexivity. {
      (* to show that there exists at least one valid read step, we pick read_done_bit_done,
         but the device could also choose read_done_bit_not_done, so later we'll have to treat
         both cases *)
      eapply read_done_bit_done with (v0 := /[1]).
      rewrite word.unsigned_of_Z_1. reflexivity.
    }
    1: eassumption.
    repeat straightline.
    straightline_call.
    (* TODO here we see that `x3 x4 x5 : word` should be named `"digest" "reg" "done"`,
       respectively, automate this naming *)
    repeat straightline.
    { (* loop condition is true: need to show that invariant still holds with smaller measure *)
      subst br.
      rename x5 into done. subst done.
      simpl_conditionals.
      eexists (v - 1).
      edestruct invert_read_status_done_false; [eassumption..|].
      subst x.
      split; [auto|lia]. }
    (* loop condition is false: need to show that code after first loop is correct *)
    subst br. simpl_conditionals.
    eassert (x = _). {
      eapply invert_read_status_done_true; eassumption.
    }
    subst x.
    straightline_call. 1: reflexivity. 1: eapply write_intr_state. 1: eassumption.
    cbn [intr_enable hmac_done hmac_en sha_en swap_endian swap_digest] in *.
    repeat straightline.

    clear dependent reg.
    repeat match goal with
           | H: execution ?t1 _ |- cmd _ _ ?t2 _ _ _ =>
             tryif unify t1 t2 then fail else clear H
           end.
    repeat match goal with
           | m1: @map.rep _ _ mem |- cmd _ _ _ ?m2 _ _ =>
             tryif unify m1 m2 then fail else clear dependent m1
           end.
    rename a3 into tr.
    clear dependent v.
    match goal with
    | H: Z.testbit \[_ ^>> _] 0 = true |- _ => rename H into T
    end.
    unfold HMAC_INTR_STATE_HMAC_DONE_BIT in *.
    rewrite word.unsigned_sru_nowrap in T. 2: {
      rewrite word.unsigned_of_Z_0. reflexivity.
    }
    rewrite word.unsigned_of_Z_0 in T.
    rewrite Z.shiftr_0_r in T.
    rewrite T in *.

    (* second while loop: *)
    eapply (while ["digest"; "reg"; "done"; "i"]
                  (fun remaining t m digest reg done i =>
                     execution t (IDLE (sha256 input)
                                       {| intr_enable := /[0];
                                          hmac_done := false;
                                          hmac_en := false;
                                          sha_en := true;
                                          swap_endian := true;
                                          swap_digest := false
                                       |}) /\
                     0 <= \[i] <= 8 /\
                     0 <= remaining <= 32 /\
                     4 * \[i] + remaining = 32 /\
                     digest = digest_addr /\
                     (bytearray digest (List.firstn (Z.to_nat (4 * \[i])) (sha256 input) ++
                                        List.skipn (Z.to_nat (4 * \[i])) digest_trash) * R)%sep m)
                  (Z.lt_wf 0) 32).
    { repeat straightline. }
    { (* invariant holds initially: *)
      loop_simpl. subst i. rewrite word.unsigned_of_Z_0.
      ssplit; try reflexivity; try assumption; try lia. }
    loop_simpl.
    repeat straightline.
    { (* running loop body satisfies invariant *)
      subst br. simpl_conditionals. subst i. rename x5 into i.
      straightline_call. 1: reflexivity. 2: eassumption. 1: eapply read_digest with (i0 := \[i]).
      all: try reflexivity.
      1-2: ZnWords.
      repeat straightline.
      eapply store_four_to_bytearray. 1: ecancel_assumption.
      { subst a2. rewrite List.app_length. rewrite List.firstn_length. rewrite List.skipn_length.
        ZnWords_pre.
        Z.div_mod_to_equations.
        (* Note: On Coq master of Aug 12, 2021, this goal is just solved by `lia`, but
           with Coq 8.13.2, `lia` hangs, so we need more manual steps: *)
        assert (2 ^ 32 <> 0) as NZ by (clear; lia).
        repeat match goal with
               | H: 2 ^ 32 = 0 -> _ |- _ => clear H
               | H: 2 ^ 32 < 0 -> _ |- _ => clear H
               | H: 0 < 2 ^ 32 -> _ |- _ => specialize (H eq_refl)
               | H: 2 ^ 32 <> 0 -> _ |- _ => specialize (H NZ)
               end.
        subst.
        clear H NZ.
        clear dependent word.
        Zify.zify.
        repeat match goal with
               | H: _ /\ _ |- _ => destruct H
               | H: _ \/ _ |- _ => destruct H
               end;
        lia.
      }
      intros m Hm.
      repeat straightline.
      exists (v - 4).
      split; [|lia].
      split. {
        subst a.
        eapply execution_step_read with (sz := 4%nat). 1: eassumption. 1: reflexivity.
        cbn [state_machine.read_step hmac_state_machine] in *.
        match goal with
        | H: read_step 4 ?s ?a ?v ?s1 |- read_step 4 ?s ?a ?v ?s2 =>
          replace s2 with s1 at 2; [exact H|]
        end.
        eapply invert_read_digest with (i := i0). 1: lia. 1: eassumption.
      }
      split; [ZnWords|].
      split; [ZnWords|].
      split; [ZnWords|].
      split; [reflexivity|].
      use_sep_assumption.
      cancel.
      cancel_seps_at_indices 0%nat 0%nat. {
        f_equal.
        rewrite List.upds_app2. 2: {
          push_length.
          (* Note: `ZnWords` should just work here, but when it calls `lia`, `lia` hangs. *)
          subst a2. rewrite H9. revert dependent v. clear -word_ok. intros.
          pose proof word.unsigned_range i0.
          replace (Init.Nat.min (Z.to_nat (4 * \[i0])) 32) with (Z.to_nat (4 * \[i0])) by lia.
          replace \[digest_addr ^+ i0 ^* /[4] ^- digest_addr] with \[i0 ^* /[4]] by ZnWords.
          ZnWords.
        }
        subst i.
        replace (Z.to_nat (4 * \[i0 ^+ /[1]])) with (Z.to_nat (4 * \[i0]) + 4)%nat by ZnWords.
        rewrite List.firstn_add. rewrite <- List.app_assoc.
        f_equal.
        unfold List.upds. push_length.
        replace (Z.to_nat \[a2 ^- digest_addr] -
                 Init.Nat.min (Z.to_nat (4 * \[i0])) (Datatypes.length (sha256 input)))%nat
          with 0%nat.
        2: {
          (* Note: `ZnWords` should just work here, but when it calls `lia`, `lia` hangs. *)
          subst a2. rewrite H9. revert dependent v. clear -word_ok. intros.
          pose proof word.unsigned_range i0.
          replace (Init.Nat.min (Z.to_nat (4 * \[i0])) 32) with (Z.to_nat (4 * \[i0])) by lia.
          replace \[digest_addr ^+ i0 ^* /[4] ^- digest_addr] with \[i0 ^* /[4]] by ZnWords.
          ZnWords.
        }
        repeat (push_firstn || push_length || listsimpl || natsimpl).
        edestruct invert_read_digest as (_ & E). 2: eassumption. 1: ZnWords. subst.
        rewrite word.unsigned_of_Z_nowrap. 2: {
          match goal with
          | |- context[le_combine ?x] =>
            pose proof (le_combine_bound x) as P
          end.
          rewrite List.firstn_length in P. rewrite min_l in P by ZnWords.
          exact P.
        }
        rewrite le_split_combine by length_hammer.
        push_skipn.
        repeat (f_equal; try lia).
      }
      ecancel_done.
    }
    (* postcondition holds at end  *)
    subst br. simpl_conditionals. subst i. rename x5 into i.
    replace (4 * \[i]) with 32 in * by ZnWords.
    rewrite List.firstn_all2 in * by ZnWords.
    rewrite List.skipn_all2 in * by ZnWords.
    autorewrite with listsimpl in *.
    subst result.
    auto.
  Qed.

End Proofs.


(* En este archivo se demuestra la corrección de la acción call *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import RuntimePermissions.
Require Import ValidStateLemmas.

Section Call.

Lemma callCorrect : forall (s:System) (ic:iCmp) (sac:SACall) (sValid: validstate s),
    (pre (call ic sac) s) -> post_call ic sac s (call_post ic sac s).
Proof.
    intros.
    unfold post_call.
    unfold call_post; simpl.
    auto.
Qed.

Lemma notPreCallThenError : forall (s:System) (ic:iCmp) (sac:SACall), ~(pre (call  ic sac) s) -> validstate s -> exists ec : ErrorCode, response (step s (call  ic sac)) = error ec /\ ErrorMsg s (call  ic sac) ec /\ s = system (step s (call  ic sac)).
Proof.
    intros.
    simpl.
    simpl in H.
    unfold pre_call in H.
    unfold call_safe.
    unfold call_pre.
    case_eq (map_apply iCmp_eq (running (state s)) ic);intros.
    case_eq (existsb (fun p : Perm => negb (appHasPermissionBool (getAppFromCmp c s) p s)) (getMandatoryPerms sac));intros.
    exists not_enough_permissions.
    split;auto.
    split;auto.
    exists c.
    split;auto.
    rewrite existsb_exists in H2.
    apply ex_not_not_all.
    destruct H2.
    destruct H2.
    exists (getAppFromCmp c s).
    apply ex_not_not_all.
    exists x.
    apply ex_not_not_all.
    assert (isSysPerm:=H2).
    apply mandatoryPermsAllSystem in isSysPerm.
    exists isSysPerm.
    rewrite negb_true_iff in H3.
    invertBool H3.
    intro;apply H3.
    apply appHasPermissionCorrect;auto.
    apply H4.
    apply ifRunningThenInApp in H1;auto.
    destruct H1.
    assert (getAppFromCmp c s=x0).
    apply inAppThenGetAppFromCmp in H1;auto.
    rewrite H5;auto.
    unfold not;intros.
    apply mandatoryPermsCorrect;auto.
    destruct H.
    exists c.
    split;auto.
    intros.
    invertBool H2.
    rewrite existsb_exists in H2.
    apply NNPP.
    intro;apply H2.
    exists p.
    split.
    apply (mandatoryPermsCorrect sac p H);auto.
    rewrite negb_true_iff.
    rewrite <-not_true_iff_false.
    intro;apply H5.
    apply inAppThenGetAppFromCmp in H3;auto.
    rewrite H3 in H6.
    apply appHasPermissionCorrect;auto.
    exists instance_not_running;auto.
Qed.

Lemma callIsSound :  forall (s:System) (ic:iCmp) (sac:SACall) (sValid: validstate s),
        exec s (call ic sac) (system (step s (call ic sac))) (response (step s (call ic sac))).
Proof.
    intros.
    unfold exec.
    split.
    auto.
    elim (classic (pre (call ic sac) s));intro.
    left.
    simpl.
    assert(call_pre ic sac s = None).
    unfold call_pre.
    destruct H.
    destruct H.
    rewrite H.
    assert (existsb (fun p : Perm => negb (appHasPermissionBool (getAppFromCmp x s) p s)) (getMandatoryPerms sac)=false).
    rewrite <-not_true_iff_false.
    unfold not;intros.
    rewrite existsb_exists in H1.
    destruct H1.
    destruct H1.
    assert (exists a:idApp, inApp x a s).
    apply (ifRunningThenInApp s sValid x ic);auto.
    destruct H3.
    assert (isSystemPerm x0).
    apply (mandatoryPermsAllSystem sac).
    auto.
    rewrite<- (mandatoryPermsCorrect sac x0 H4) in H1.
    specialize (H0 x1 x0 H4 H3 H1).
    rewrite negb_true_iff in H2.
    rewrite<- not_true_iff_false in H2.
    apply H2.
    assert (getAppFromCmp x s = x1).
    apply inAppThenGetAppFromCmp;auto.
    rewrite H5.
    apply appHasPermissionCorrect; auto.
    rewrite H1.
    auto.

    unfold call_safe;simpl.
    rewrite H0;simpl.
    split;auto.
    split;auto.
    apply callCorrect;auto.
    right.
    apply notPreCallThenError;auto.

Qed.
End Call.


Require Import VST.floyd.proofauto.
Require Import malloc_lemmas.
Require Import malloc_sep.
Require Import malloc.
Require Import spec_malloc.
Require Import linking.

Definition Gprog : funspecs := try_pre_fill_spec' ::  external_specs ++ user_specs_R ++ private_specs.
(* It's sort of a hack that try_pre_fill_spec' is included in Gprog here.
  If we don't, and since nobody else calls this function or includes it in their own
  Gprog, then try_pre_fill_spec' won't be in any of the Gprogs;
 that means it won't be in the combined link_main.Gprog,
  and then link_main.prog_correct will fail.
*)

Lemma add_resvec_0:
  forall rvec b, 0 <= b < BINS -> Zlength rvec = BINS -> (add_resvec rvec b 0) = rvec.
Proof.
  intros. unfold add_resvec.
  bdestruct(Zlength rvec =? BINS); [ | rep_omega].
  bdestruct(0 <=? b); [ | rep_omega].
  bdestruct(b <? BINS); [ | rep_omega].
  simpl.
  replace (Znth b rvec + 0) with (Znth b rvec) by omega.
  rewrite upd_Znth_same_val; [auto | rep_omega].
Qed.

Lemma add_resvec_plus:
  forall rvec b n m, 0 <= b < BINS -> Zlength rvec = BINS ->
    (add_resvec (add_resvec rvec b n) b m) = (add_resvec rvec b (n+m)).
Proof.
  intros. unfold add_resvec.
  bdestruct(Zlength rvec =? BINS); [ | rep_omega].
  bdestruct(0 <=? b); [ | rep_omega].
  bdestruct(b <? BINS); [ | rep_omega]; simpl.
  rewrite upd_Znth_Zlength.
  bdestruct(Zlength rvec =? BINS); [ | rep_omega]; simpl.
  rewrite upd_Znth_same; try rep_omega.
  rewrite upd_Znth_twice; try rep_omega.
  rewrite Z.add_assoc; reflexivity. rep_omega.
Qed.

Lemma body_try_pre_fill:  semax_body Vprog Gprog f_try_pre_fill try_pre_fill_spec'.
Proof.
start_function.
destruct H as [[Hnlo Hnhi] [Hreqlo Hreqhi]].
assert_PROP (Zlength rvec = BINS) as Hrvec. {
  unfold mem_mgr_R. entailer. rewrite Zlength_map in H0. entailer!. }
forward_call(BINS-1). (*! t1 = bin2size(BINS-1) *)
rep_omega.
forward_if. (*! if n > t1 *)
(* large case *)
{ forward. (*! return 0 *)
  Exists 0.
  entailer!.
  rewrite add_resvec_0; try rep_omega.
}
(* small case *)
forward_call n; try rep_omega. (*! b = size2bin(n) *)
forward. (*! ful = 0 *)
deadvars!.
set (b:=size2binZ n).
assert (Hb: 0 <= b < BINS) by (apply (size2bin_range n); rep_omega).
forward_call b. (*! t3 = bin2size(b) *)
forward. (*! chunks = (BIGBLOCK - WASTE) / t3 + WORD) *)
entailer!.
          pose proof (bin2size_range b Hb);
          apply repr_inj_unsigned in H0; rep_omega.
forward_while (*! while (req - ful > 0) *)
    (EX ful:_,
    PROP ( 0 <= ful <= Int.max_signed )
     LOCAL (temp _n (Vptrofs (Ptrofs.repr n)); temp _req (Vptrofs (Ptrofs.repr req));
            temp _b (Vint (Int.repr b)); temp _ful (Vint (Int.repr ful));
            temp _chunks (Vint (Int.repr((BIGBLOCK-WA)/(bin2sizeZ b + WORD))));
            gvars gv)
     SEP (mem_mgr_R gv (add_resvec rvec (size2binZ n) ful))).
- (* init *)
Exists 0.
rewrite add_resvec_0; try rep_omega.
entailer!.
   f_equal.
   unfold Int.divu.
   f_equal.
   pose proof (bin2size_range b Hb); rewrite !Int.unsigned_repr by rep_omega.
   reflexivity.
- (* typecheck guard *)
entailer!.
- (* body preserves *)
forward_if. (*! if (UINT_MAX - ful < chunks) *)
(* case overflow *)
{ forward. (*! return ful *)
  Exists ful.
  entailer!.
}
(* continue *)
forward_call BIGBLOCK. (*! t3 = mmap0(BIGBLOCK) *)
rep_omega.
Intros p.
forward_if. (*! if p==null *)
-- if_tac; entailer!.
-- (* case p==null *)
if_tac. forward. Exists ful. entailer!. contradiction.
-- (* case p<>null *)
forward_call (n,p,gv,(add_resvec rvec b ful)). (*! pre_fill(n,p) *)
if_tac. contradiction. subst b. entailer!.
destruct (eq_dec p nullval). contradiction.
split; [rep_omega|auto].
forward. (*! ful += chunks *)
(* restore invar *)
Exists (ful + chunks_from_block b).
entailer!.
+
  unfold chunks_from_block.
  bdestruct (0 <=? b); [ | omega].
  bdestruct (b <? BINS); [ | omega].
  simpl.
  split; auto.
  pose proof (bin2size_range b Hb).
  assert (0 <= (BIGBLOCK - WA) / (bin2sizeZ b + WORD))
   by (apply Z.div_pos; rep_omega).
  rewrite Int.signed_repr in H1.
  split; try rep_omega.
  split; try rep_omega.
  apply Zdiv_le_upper_bound.
  rep_omega. rep_omega.
 +
  entailer!.
  rewrite add_resvec_plus.
  subst b.
  entailer!.
  apply size2bin_range; rep_omega.
  rep_omega.
- (* after loop *)
forward. (*! return ful *)
Exists ful.
entailer!.
Qed.

Definition module := [mk_body body_try_pre_fill].


Require Import Coq.Lists.List.
Import ListNotations.

Require Import Tactics.
Require Import Axioms.
Require Import Sigma.
Require Import Equality.
Require Import Sequence.
Require Import Relation.
Require Import Ordinal.
Require Import Syntax.
Require Import SimpSub.
Require Import Dynamic.
Require Import Ofe.
Require Import Uniform.
Require Import Intensional.
Require Import Candidate.
Require Import System.
Require Import Semantics.
Require Import SemanticsKnot.
Require Import Judgement.
Require Import Hygiene.
Require Import ProperClosed.
Require Import ProperFun.
Require Import Shut.

Require Import SoundUtil.
Require Import Ceiling.
Require Import Truncate.
Require Import Urelsp.
Require Import SemanticsSet.
Require Import ProperDownward.
Require Import ProperLevel.
Require Import Equivalence.
Require Import Subsumption.
Require Import SemanticsSimple.
Require Import SemanticsPi.
Require Import Defined.

Local Ltac prove_hygiene :=
  repeat (first [ eapply subst_closub; eauto
                | apply closub_dot
                | apply hygiene_auto; cbn; repeat2 split; auto
                ]);
  eauto using hygiene_weaken, clo_min, hygiene_shift', hygiene_subst1;
  try (apply hygiene_var; cbn; auto; done).

Lemma sound_set_formation_main :
  forall lvo G a b c d mr ml,
    hygiene (ctxpred G) a
    -> hygiene (ctxpred G) b
    -> hygiene (permit (ctxpred G)) c
    -> hygiene (permit (ctxpred G)) d
    -> (forall i s s',
          pwctx i s s' G
          -> exists pg R,
               pgointerp s lvo pg
               /\ pgointerp s' lvo pg
               /\ interp pg true i (subst s a) R
               /\ interp pg false i (subst s' a) R
               /\ interp pg true i (subst s b) R
               /\ interp pg false i (subst s' b) R)
    -> (forall i s s',
          pwctx i s s' (hyp_tm a :: G)
          -> exists pg R,
               pgointerp (compose sh1 s) lvo pg
               /\ interp pg true i (subst s c) R
               /\ interp pg false i (subst s' c) R)
    -> (forall i s s',
          pwctx i s s' (hyp_tm a :: G)
          -> exists pg R,
               pgointerp (compose sh1 s) lvo pg
               /\ interp pg true i (subst s d) R
               /\ interp pg false i (subst s' d) R)
    -> (forall i s s',
          pwctx i s s' (hyp_tm c :: hyp_tm a :: G)
          -> exists R,
               interp toppg true i (subst s (subst sh1 d)) R
               /\ interp toppg false i (subst s' (subst sh1 d)) R
               /\ rel (den R) i (subst s mr) (subst s' mr))
    -> (forall i s s',
          pwctx i s s' (hyp_tm d :: hyp_tm a :: G)
          -> exists R,
               interp toppg true i (subst s (subst sh1 c)) R
               /\ interp toppg false i (subst s' (subst sh1 c)) R
               /\ rel (den R) i (subst s ml) (subst s' ml))
    -> forall i s s',
         pwctx i s s' G
         -> exists pg R,
              pgointerp s lvo pg
              /\ pgointerp s' lvo pg
              /\ interp pg true i (subst s (set a c)) R
              /\ interp pg false i (subst s' (set a c)) R
              /\ interp pg true i (subst s (set b d)) R
              /\ interp pg false i (subst s' (set b d)) R.
Proof.
intros lvo G a b c d mr ml Hcla Hclb Hclc Hcld Hseqab Hseqc Hseqd Hseqcd Hseqdc i s s' Hs.
so (seqctx_impl_closub _#4 (pwctx_impl_seqctx _#4 Hs)) as (Hcls & Hcls').
so (Hseqab _#3 Hs) as (pg & A & Hlvl & Hlvr & Hal & Har & Hbl & Hbr).
assert (den A = ceiling (S i) (den A)) as HeqA.
  {
  so (basic_impl_iutruncate _#6 Hal) as Heq.
  exact (f_equal den Heq).
  }
exploit (extract_functional pg i (den A) (subst (under 1 s) c) (subst (under 1 s') c)) as (C & Hcl & Hcr); eauto using subst_closub_under_permit.
  {
  intros j m p Hmp.
  assert (pwctx j (dot m s) (dot p s') (cons (hyp_tm a) G)) as Hss.
    {
    assert (j <= i) as Hj.
      {
      rewrite -> HeqA in Hmp.
      destruct Hmp.
      omega.
      }
    apply pwctx_cons_tm_seq; eauto using pwctx_downward.
      {
      eapply seqhyp_tm_leq; eauto using interp_increase, toppg_max.
      }

      {
      intros j' t t' Ht.
      so (Hseqab _#3 Ht) as (pg' & R & _ & _ & Hl & Hr & _).
      eauto.
      }
    }
  so (Hseqc _#3 Hss) as (pg' & R & Hlv' & Hcl & Hcr).
  simpsubin Hlv'.
  so (pgointerp_fun _#4 Hlvl Hlv'); subst pg'.
  exists R.
  simpsub.
  auto.
  }
exploit (extract_functional pg i (den A) (subst (under 1 s) d) (subst (under 1 s') d)) as (D & Hdl & Hdr); eauto using subst_closub_under_permit.
  {
  intros j m p Hmp.
  assert (pwctx j (dot m s) (dot p s') (cons (hyp_tm a) G)) as Hss.
    {
    assert (j <= i) as Hj.
      {
      rewrite -> HeqA in Hmp.
      destruct Hmp.
      omega.
      }
    apply pwctx_cons_tm_seq; eauto using pwctx_downward.
      {
      eapply seqhyp_tm_leq; eauto using interp_increase, toppg_max.
      }

      {
      intros j' t t' Ht.
      so (Hseqab _#3 Ht) as (pg' & R & _ & _ & Hl & Hr & _).
      eauto.
      }
    }
  so (Hseqd _#3 Hss) as (pg' & R & Hlv' & Hdl & Hdr).
  simpsubin Hlv'.
  so (pgointerp_fun _#4 Hlvl Hlv'); subst pg'.
  exists R.
  simpsub.
  auto.
  }
exists pg, (iuset stop A C).
assert (forall j e m n p q E (Hmn : rel (den A) j m n),
          functional the_system pg true i (den A) (subst (under 1 s) e) E
          -> functional the_system pg false i (den A) (subst (under 1 s') e) E
          -> rel (den (pi1 E (urelspinj (den A) j m n Hmn))) j p q
          -> (forall i s s',
                pwctx i s s' (hyp_tm a :: G)
                -> exists pg R,
                     pgointerp (compose sh1 s) lvo pg
                     /\ interp pg true i (subst s e) R
                     /\ interp pg false i (subst s' e) R)
          -> pwctx j (dot p (dot m s)) (dot q (dot n s')) (hyp_tm e :: hyp_tm a :: G)) as Hext.
  {
  intros j e m n p q E Hmn Hel Her Hpq Hseqe.
  so (basic_member_index _#9 Hal Hmn) as Hj.
  apply pwctx_cons_tm_seq.
    {
    apply pwctx_cons_tm_seq; eauto using pwctx_downward.
      {
      eapply (seqhyp_tm _#5 (iutruncate (S j) A)).
        {
        apply (basic_downward _#3 i); auto.
        eapply interp_increase; eauto using toppg_max.
        }

        {
        apply (basic_downward _#3 i); auto.
        eapply interp_increase; eauto using toppg_max.
        }

        {
        split; auto.
        }
      }

      {
      intros k u u' Hu.
      so (Hseqab _#3 Hu) as (pg' & A' & _ & _ & Hl & Hr & _).
      eauto.
      }
    }

    {
    invert Hel.
    intros _ _ Hact.
    so (Hact _#3 Hj Hmn) as Hmel; clear Hact.
    simpsubin Hmel.
    invert Her.
    intros _ _ Hact.
    so (Hact _#3 Hj Hmn) as Hmer; clear Hact.
    simpsubin Hmer.
    eapply seqhyp_tm; eauto using interp_increase, toppg_max.
    }

    {
    intros k u u' Hu.
    so (Hseqe _#3 Hu) as (pg' & R & _ & Hl & Hr).
    simpsubin Hl.
    simpsubin Hr.
    eauto.
    }
  }
assert (iuset stop A C = iuset stop A D) as Heq.
  {
  apply prod_extensionality; cbn; auto.
  apply urel_extensionality.
  fextensionality 3.
  intros j m n.
  cbn.
  pextensionality.
    {
    intro H.
    decompose H.
    intros p q Hmn Hpq.
    so (basic_member_index _#9 Hal Hmn) as Hj.
    so (Hext _#7 Hmn Hcl Hcr Hpq Hseqc) as Hs'.
    so (Hseqcd _#3 Hs') as (R & Hmdl & _ & Hx).
    simpsubin Hmdl.
    invert Hdl.
    intros _ _ Hact.
    so (Hact _#3 Hj Hmn) as Hmdl'.
    simpsubin Hmdl'.
    so (interp_fun _#7 Hmdl Hmdl'); subst R.
    exists (subst (dot p (dot m s)) mr), (subst (dot q (dot n s')) mr), Hmn.
    auto.
    }

    {
    intro H.
    decompose H.
    intros p q Hmn Hpq.
    so (basic_member_index _#9 Hal Hmn) as Hj.
    so (Hext _#7 Hmn Hdl Hdr Hpq Hseqd) as Hs'.
    so (Hseqdc _#3 Hs') as (R & Hmdl & _ & Hx).
    simpsubin Hmdl.
    invert Hcl.
    intros _ _ Hact.
    so (Hact _#3 Hj Hmn) as Hmdl'.
    simpsubin Hmdl'.
    so (interp_fun _#7 Hmdl Hmdl'); subst R.
    exists (subst (dot p (dot m s)) ml), (subst (dot q (dot n s')) ml), Hmn.
    auto.
    }
  }
simpsub.
do2 5 split; auto.
  {
  apply interp_eval_refl.
  apply interp_set; auto.
  }

  {
  apply interp_eval_refl.
  apply interp_set; auto.
  }

  {
  rewrite -> Heq.
  apply interp_eval_refl.
  apply interp_set; auto.
  }

  {
  rewrite -> Heq.
  apply interp_eval_refl.
  apply interp_set; auto.
  }
Qed.

Lemma sound_set_formation :
  forall G a a' b b' mr ml,
    pseq G (deqtype a a')
    -> pseq (cons (hyp_tm a) G) (deqtype b b)
    -> pseq (cons (hyp_tm a) G) (deqtype b' b')
    (* b implies b' *)
    -> pseq (hyp_tm b :: hyp_tm a :: G)
         (deq mr mr (subst sh1 b'))
    (* b' implies b *)
    -> pseq (hyp_tm b' :: hyp_tm a :: G)
         (deq ml ml (subst sh1 b))
    -> pseq G (deqtype (set a b) (set a' b')).
Proof.
intros G a b c d mr ml.
revert G.
refine (seq_pseq 4 [] a [] b [hyp_emp] c [hyp_emp] d 5 [] _ [_] _ [_] _ [_; _] _ [_; _] _ _ _); cbn.
intros G Hcla Hclb Hclc Hcld Hseqab Hseqc Hseqd Hseqcd Hseqdc.
rewrite -> seq_eqtype in Hseqab, Hseqc, Hseqd |- *.
rewrite -> seq_deq in Hseqcd, Hseqdc.
exploit (sound_set_formation_main None G a b c d mr ml) as H; auto.
  {
  intros i s s' Hs.
  so (Hseqab _#3 Hs) as (R & H).
  exists toppg, R.
  do2 2 split; auto; cbn; auto.
  }

  {
  intros i s s' Hs.
  so (Hseqc _#3 Hs) as (R & Hl & Hr & _).
  exists toppg, R.
  split; auto.
  cbn.
  reflexivity.
  }

  {
  intros i s s' Hs.
  so (Hseqd _#3 Hs) as (R & Hl & Hr & _).
  exists toppg, R.
  split; auto.
  cbn.
  reflexivity.
  }

  {
  intros i s s' Hs.
  so (Hseqcd _#3 Hs) as (R & Hl & Hr & Hm & _).
  eauto.
  }

  {
  intros i s s' Hs.
  so (Hseqdc _#3 Hs) as (R & Hl & Hr & Hm & _).
  eauto.
  }
intros i s s' Hs.
so (H _#3 Hs) as (pg & R & Hlv & _ & H').
cbn in Hlv.
subst pg.
eauto.
Qed.

Lemma sound_set_formation_univ :
  forall G lv a a' b b' mr ml,
    pseq G (deq a a' (univ lv))
    -> pseq (cons (hyp_tm a) G) (deq b b (univ (subst sh1 lv)))
    -> pseq (cons (hyp_tm a) G) (deq b' b' (univ (subst sh1 lv)))
    (* b implies b' *)
    -> pseq (hyp_tm b :: hyp_tm a :: G)
         (deq mr mr (subst sh1 b'))
    (* b' implies b *)
    -> pseq (hyp_tm b' :: hyp_tm a :: G)
         (deq ml ml (subst sh1 b))
    -> pseq G (deq (set a b) (set a' b') (univ lv)).
Proof.
intros G lv a b c d mr ml.
revert G.
refine (seq_pseq 4 [] a [] b [hyp_emp] c [hyp_emp] d 5 [] _ [_] _ [_] _ [_; _] _ [_; _] _ _ _); cbn.
intros G Hcla Hclb Hclc Hcld Hseqab Hseqc Hseqd Hseqcd Hseqdc.
rewrite -> seq_univ in Hseqab, Hseqc, Hseqd |- *.
rewrite -> seq_deq in Hseqcd, Hseqdc.
exploit (sound_set_formation_main (Some lv) G a b c d mr ml) as H; auto.
  {
  intros i s s' Hs.
  so (Hseqc _#3 Hs) as (pg & R & Hlv & _ & Hl & Hr & _).
  exists pg, R.
  split; auto.
  unfold pgointerp.
  simpsubin Hlv.
  exact Hlv.
  }

  {
  intros i s s' Hs.
  so (Hseqd _#3 Hs) as (pg & R & Hlv & _ & Hl & Hr & _).
  exists pg, R.
  split; auto.
  unfold pgointerp.
  simpsubin Hlv.
  exact Hlv.
  }

  {
  intros i s s' Hs.
  so (Hseqcd _#3 Hs) as (R & Hl & Hr & Hm & _).
  eauto.
  }

  {
  intros i s s' Hs.
  so (Hseqdc _#3 Hs) as (R & Hl & Hr & Hm & _).
  eauto.
  }
Qed.

Lemma sound_set_intro :
  forall G a b m n p,
    pseq G (deq m n a)
    -> pseq G (deq p p (subst1 m b))
    -> pseq (hyp_tm a :: G) (deqtype b b)
    -> pseq G (deq m n (set a b)).
Proof.
intros G a b m n p.
revert G.
refine (seq_pseq 1 [hyp_emp] b 3 [] _ [] _ [_] _ _ _); cbn.
intros G Hclb Hseqmn Hseqp Hseqb.
rewrite -> seq_eqtype in Hseqb.
rewrite -> seq_deq in Hseqmn, Hseqp |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
so (Hseqmn _#3 Hs) as (A & Hal & Har & Hm & Hn & Hmn).
assert (den A = ceiling (S i) (den A)) as HeqA.
  {
  so (basic_impl_iutruncate _#6 Hal) as Heq.
  exact (f_equal den Heq).
  }
exploit (extract_functional toppg i (den A) (subst (under 1 s) b) (subst (under 1 s') b)) as (B & Hbl & Hbr); eauto using subst_closub_under_permit.
  {
  intros j r t Hrt.
  assert (pwctx j (dot r s) (dot t s') (cons (hyp_tm a) G)) as Hss.
    {
    assert (j <= i) as Hj.
      {
      rewrite -> HeqA in Hrt.
      destruct Hrt.
      omega.
      }
    apply pwctx_cons_tm_seq; eauto using pwctx_downward.
      {
      eapply seqhyp_tm_leq; eauto using interp_increase, toppg_max.
      }

      {
      intros j' u u' Hu.
      so (Hseqmn _#3 Hu) as (R & Hl & Hr & _).
      eauto.
      }
    }
  so (Hseqb _#3 Hss) as (R & Hbl & Hbr & _).
  exists R.
  simpsub.
  auto.
  }
so (Hseqp _#3 Hs) as (Bm & Hbml & _ & Hp & _).
simpsubin Hbml.
invert Hbl.
intros _ _ Hact.
so (Hact _#3 (le_refl _) Hm) as H.
simpsubin H.
so (basic_fun _#7 H Hbml); subst Bm; clear H Hbml.
exists (iuset stop A B).
simpsub.
do2 4 split;
try (apply interp_eval_refl;
     apply interp_set; auto).
  {
  cbn.
  exists (subst s p), (subst s' p), Hm.
  auto.
  }

  {
  cbn.
  exists (subst s p), (subst s' p), Hn.
  force_exact Hp.
  do 3 f_equal.
  apply urelspinj_equal; auto.
  }

  {
  cbn.
  exists (subst s p), (subst s' p), Hmn.
  force_exact Hp.
  do 3 f_equal.
  apply urelspinj_equal; auto.
  }
Qed.

Lemma sound_set_elim1 :
  forall G a b m n,
    pseq G (deq m n (set a b))
    -> pseq G (deq m n a).
Proof.
intros G a b m n.
revert G.
refine (seq_pseq 0 1 [] _ _ _); cbn.
intros G Hseq.
rewrite -> seq_deq in Hseq |- *.
intros i s s' Hs.
so (Hseq i s s' Hs) as (R & Hl & Hr & Hm & Hn & Hmn); clear Hseq.
simpsubin Hl.
simpsubin Hr.
invert (basic_value_inv _#6 value_set Hl).
intros A B Ha Hb Heq1.
invert (basic_value_inv _#6 value_set Hr).
intros A' B' Ha' Hb' Heq2.
so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
clear Heq2.
subst R.
so (iuset_inj _#5 Heq); subst A'.
exists A.
do2 4 split; auto.
  {
  cbn in Hm.
  decompose Hm.
  intros _ _ H _.
  auto.
  }

  {
  cbn in Hn.
  decompose Hn.
  intros _ _ H _.
  auto.
  }

  {
  cbn in Hmn.
  decompose Hmn.
  intros _ _ H _.
  auto.
  }
Qed.

Lemma sound_set_elim2 :
  forall G a b m J,
    pseq G (deq m m (set a b))
    -> pseq (hyp_tm a :: G) (deqtype b b)
    -> pseq (hyp_tm (subst1 m b) :: G) (substj sh1 J)
    -> pseq G J.
Proof.
intros G a b m J.
revert G.
refine (seq_pseq 0 3 [] _ [_] _ [_] _ _ _); cbn.
intros G Hseqm Hseqb Hseqnp.
rewrite -> seq_eqtype in Hseqb.
destruct J as [n p c].
simpsubin Hseqnp.
rewrite -> seq_deq in Hseqm, Hseqnp |- *.
assert (forall i s s',
          pwctx i s s' G
          -> pwctx i (dot (subst s m) s) (dot (subst s' m) s') (hyp_tm a :: G)) as Hsm.
  {
  intros i s s' Hs.
  apply pwctx_cons_tm_seq; auto.
    {
    so (Hseqm _#3 Hs) as (R & Hl & Hr & Hm & _).
    simpsubin Hl.
    simpsubin Hr.
    invert (basic_value_inv _#6 value_set Hl).
    intros A B Hal _ Heq1.
    invert (basic_value_inv _#6 value_set Hr).
    intros A' B' Har _ Heq2.
    so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
    clear Heq2.
    subst R.
    so (iuset_inj _#5 Heq); subst A'.
    cbn in Hm.
    decompose Hm.
    intros _ _ Hm' _.
    apply (seqhyp_tm _#5 A); auto.
    }

    {
    intros j u u' Hu.
    so (Hseqm _#3 Hu) as (R & Hl & Hr & Hm & _).
    simpsubin Hl.
    simpsubin Hr.
    invert (basic_value_inv _#6 value_set Hl).
    intros A B Hal _ Heq1.
    invert (basic_value_inv _#6 value_set Hr).
    intros A' B' Har _ Heq2.
    so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
    clear Heq2.
    so (iuset_inj _#5 Heq); subst A'.
    eauto.
    }
  }
intros i s s' Hs.
so (Hseqm _#3 Hs) as (R & Hl & Hr & Hm & _).
simpsubin Hl.
simpsubin Hr.
invert (basic_value_inv _#6 value_set Hl); clear Hl.
intros A B Hal Hbl Heq1.
invert (basic_value_inv _#6 value_set Hr); clear Hr.
intros A' B' Har _ Heq2.
so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
clear Heq2.
subst R.
so (iuset_inj _#5 Heq); subst A'.
clear B' Heq.
cbn in Hm.
decompose Hm.
intros q r Hm Hqr.
assert (pwctx i (dot q s) (dot r s') (hyp_tm (subst1 m b) :: G)) as Hsqr.
  {
  apply pwctx_cons_tm_seq; auto.
    {
    simpsub.
    apply (seqhyp_tm _#5 (pi1 B (urelspinj _#4 Hm))); auto.
      {
      invert Hbl.
      intros _ _ Hact.
      so (Hact _#3 (le_refl _) Hm) as H.
      simpsubin H.
      exact H.
      }

      {
      invert Hbl.
      intros _ _ Hact.
      so (Hact _#3 (le_refl _) Hm) as Hbml.
      so (Hseqb _#3 (Hsm _#3 Hs)) as (Bm & Hbml' & Hbmr & _).
      simpsubin Hbml.
      simpsubin Hbml'.
      so (basic_fun _#7 Hbml Hbml'); subst Bm.
      exact Hbmr.
      }
    }

    {
    intros j u u' Hu.
    so (Hseqb _#3 (Hsm _#3 Hu)) as (R & Hl & Hr & _).
    simpsub.
    eauto.
    }
  }
so (Hseqnp _#3 Hsqr) as (C & Hcl & Hcr & Hn & Hp & Hnp).
simpsubin Hcl.
simpsubin Hcr.
simpsubin Hn.
simpsubin Hp.
simpsubin Hnp.
exists C.
do2 4 split; auto.
Qed.

Lemma interp_set_invert :
  forall pg s s' i a a' b b' R,
    interp pg s i (set a b) R
    -> interp pg s' i (set a' b') R
    -> exists A,
         interp pg s i a A
         /\ interp pg s' i a' A.
Proof.
intros pg s s' i a a' b b' R Hl Hr.
invert (basic_value_inv _#6 value_set Hl).
intros A B Hal _ Heq1.
invert (basic_value_inv _#6 value_set Hr).
intros A' B' Hal' _ Heq2.
so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
clear Heq1 Heq2.
so (iuset_inj _#5 Heq); subst A'.
eauto.
Qed.

Lemma sound_set_hyp_weaken :
  forall G1 G2 a b J,
    pseq (G2 ++ hyp_tm b :: hyp_tm a :: G1) J
    -> pseq (G2 ++ hyp_tm b :: hyp_tm (set a b) :: G1) J.
Proof.
intros G1 G2 a b J.
revert G1.
refine (seq_pseq_hyp 0 1 _ [_; _] _ _ [_; _] _ _); cbn.
intros G Hseq HclJ.
replace J with (substj (under (length G2) id) J) in Hseq by (simpsub; reflexivity).
replace G2 with (substctx id G2) in Hseq by (simpsub; reflexivity).
eapply (subsume_seq _ _ (under (length G2) id)); eauto.
rewrite -> length_substctx.
apply subsume_under.
do2 2 split.
  {
  intros j.
  split.
    {
    intros Hj.
    simpsub.
    apply hygiene_var.
    rewrite -> ctxpred_length in Hj |- *.
    cbn in Hj |- *.
    omega.
    }

    {
    intros Hj.
    simpsub.
    simpsubin Hj.
    invertc Hj.
    intro Hj.
    rewrite -> ctxpred_length in Hj |- *.
    cbn in Hj |- *.
    omega.
    }
  }

  {
  intros j.
  split.
    {
    intros Hj.
    simpsub.
    apply hygiene_var.
    rewrite -> ctxpred_length in Hj |- *.
    cbn in Hj |- *.
    omega.
    }

    {
    intros Hj.
    simpsub.
    simpsubin Hj.
    invertc Hj.
    intro Hj.
    rewrite -> ctxpred_length in Hj |- *.
    cbn in Hj |- *.
    omega.
    }
  }
intros i ss ss' Hss.
invertc Hss.
intros p q ss2 ss2' Hss Hpq Hleft2 Hright2 <- <-.
invertc Hss.
intros m n s s' Hs Hmn Hleft1 Hright1 <- <-.
simpsubin Hmn.
invertc Hmn.
intros R Hsetl Hsetr Hmn.
invertc Hpq.
intros Bm Hbml Hbnr Hpq.
invert (basic_value_inv _#6 value_set Hsetl).
intros A B Hal Hbl Heq1.
invert (basic_value_inv _#6 value_set Hsetr).
intros A' B' Har Hbr Heq2.
so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
clear Heq2.
subst R.
so (iuset_inj _#5 Heq); subst A'; clear Heq.
so Hmn as Hmnset.
cbn in Hmn.
decompose Hmn.
intros _ _ Hmn _.
invert Hbl.
intros _ _ Hact.
so (Hact _ _ _ (le_refl _) Hmn) as H; clear Hact.
simpsubin H.
so (basic_fun _#7 Hbml H); subst Bm; clear H.
do2 4 split.
  {
  simpsub.
  apply pwctx_cons_tm.
    {
    apply pwctx_cons_tm; auto.
      {
      eapply seqhyp_tm; eauto.
      }

      {
      intros j u Hj Hu.
      exploit (Hleft1 j false u) as H; auto using smaller_le, pwctx_impl_seqctx.
      rewrite -> qpromote_hyp_tm in H.
      simpsubin H.
      invertc H.
      intros R Hsetr' Hsetu.
      so (interp_set_invert _#9 Hsetr' Hsetu) as (A' & Har' & Hau).
      eapply relhyp_tm; eauto.
      }

      {
      intros j u Hj Hu.
      exploit (Hright1 j false u) as H; auto using smaller_le, pwctx_impl_seqctx.
      rewrite -> qpromote_hyp_tm in H.
      simpsubin H.
      invertc H.
      intros R Hsetu Hsetl'.
      so (interp_set_invert _#9 Hsetu Hsetl') as (A' & Har' & Hau).
      eapply relhyp_tm; eauto.
      }
    }

    {
    eapply seqhyp_tm; eauto.
    }

    {
    intros j uu Hj Huu.
    exploit (Hleft2 j false uu) as H; auto using smaller_le, pwctx_impl_seqctx.
    rewrite -> qpromote_cons.
    cbn.
    invertc Huu.
    intros n' u Hu Hmn' _ _ <-.
    apply seqctx_cons; auto using pwctx_impl_seqctx.
    simpsub.
    simpsubin Hmn'.
    invertc Hmn'.
    intros A' Hal' Hau Hmn'.
    so (basic_fun _#7 (basic_downward _#7 Hj Hal) Hal'); subst A'; clear Hal'.
    apply (seqhyp_tm _#5 (iutruncate (S j) (iuset _ A B))).
      {
      eapply basic_downward; eauto.
      }

      {
      exploit (Hleft1 j false u) as H; auto using smaller_le, pwctx_impl_seqctx.
      rewrite -> qpromote_hyp_tm in H.
      simpsubin H.
      invertc H.
      intros R Hsetr' Hsetu.
      so (basic_fun _#7 (basic_downward _#7 Hj Hsetr) Hsetr'); subst R.
      exact Hsetu.
      }

      {
      cbn.
      split; [omega |].
      destruct Hmn' as (_ & Hmn').
      exists p, q, Hmn'.
      refine (rel_from_dist _#6 _ (urel_downward_leq _#6 Hj Hpq)).
      apply den_nonexpansive.
      apply (pi2 B).
      apply urelspinj_dist_diff; auto.
      }
    }

    {
    intros j uu Hj Huu.
    exploit (Hright2 j false uu) as H; auto using smaller_le, pwctx_impl_seqctx.
    rewrite -> qpromote_cons.
    cbn.
    invertc Huu.
    intros m' u Hu Hmn' _ _ <-.
    apply seqctx_cons; auto using pwctx_impl_seqctx.
    simpsub.
    simpsubin Hmn'.
    invertc Hmn'.
    intros A' Hau Har' Hmn'.
    so (basic_fun _#7 (basic_downward _#7 Hj Har) Har'); subst A'; clear Har'.
    apply (seqhyp_tm _#5 (iutruncate (S j) (iuset _ A B))).
    2:{
      eapply basic_downward; eauto.
      }

      {
      exploit (Hright1 j false u) as H; auto using smaller_le, pwctx_impl_seqctx.
      rewrite -> qpromote_hyp_tm in H.
      simpsubin H.
      invertc H.
      intros R Hsetl' Hsetu.
      so (basic_fun _#7 (basic_downward _#7 Hj Hsetl) Hsetl'); subst R.
      exact Hsetu.
      }

      {
      cbn.
      split; [omega |].
      destruct Hmn' as (_ & Hmn').
      exists p, q, Hmn'.
      refine (rel_from_dist _#6 _ (urel_downward_leq _#6 Hj Hpq)).
      apply den_nonexpansive.
      apply (pi2 B).
      apply urelspinj_dist_diff; auto.
      eapply urel_downward_leq; eauto.
      }
    }
  }

  {
  simpsub.
  apply equivsub_refl.
  }

  {
  simpsub.
  apply equivsub_refl.
  }

  {
  intros j d uu Hsmall Huu.
  so (smaller_impl_le _#3 Hsmall) as Hj.
  simpsubin Huu.
  simpsub.
  rewrite -> !qpromote_cons in Huu |- *.
  rewrite -> !qpromote_hyp_tm in Huu |- *.
  invertc Huu.
  intros q' uu2 Huu Hpq' <-.
  invertc Huu.
  intros n' u Hu Hmn' <-.
  apply seqctx_cons.
    {
    apply seqctx_cons; auto.
    simpsub.
    apply (seqhyp_tm _#5 (iutruncate (S j) (iuset stop A B))).
      {
      apply (basic_downward _#3 i); auto.
      }

      {
      exploit (Hleft1 j d u) as H; auto.
      rewrite -> qpromote_hyp_tm in H.
      simpsubin H.
      simpsub.
      invertc H.
      intros R Hsetr' Hsetu.
      so (basic_fun _#7 (basic_downward _#7 Hj Hsetr) Hsetr'); subst R.
      auto.
      }

      {
      split; auto.
      cbn.
      simpsubin Hmn'.
      invertc Hmn'.
      intros R Hal' _ Hmn'.
      so (basic_fun _#7 (basic_downward _#7 Hj Hal) Hal'); subst R.
      destruct Hmn' as (_ & Hmn').
      exists p, q, Hmn'.
      refine (rel_from_dist _#6 _ (urel_downward_leq _#6 Hj Hpq)).
      apply den_nonexpansive.
      apply (pi2 B).
      apply urelspinj_dist_diff; auto.
      }
    }

    {
    simpsub.
    invertc Hmn'.
    intros R Hal' _ Hmn'.
    so (basic_fun _#7 (basic_downward _#7 Hj Hal) Hal'); subst R.
    destruct Hmn' as (_ & Hmn').
    invert Hbl.
    intros _ _ Hact.
    so (Hact _#3 Hj Hmn') as Hmblj; clear Hact.
    simpsubin Hmblj.
    simpsubin Hpq'.
    invertc Hpq'.
    intros R Hmblj' Hmbu Hpq'.
    so (basic_fun _#7 Hmblj Hmblj'); subst R.
    apply (seqhyp_tm _#5 (pi1 B (urelspinj _#4 Hmn'))); auto.
    }
  }

  {
  intros j d uu Hsmall Huu.
  so (smaller_impl_le _#3 Hsmall) as Hj.
  simpsubin Huu.
  simpsub.
  rewrite -> !qpromote_cons in Huu |- *.
  rewrite -> !qpromote_hyp_tm in Huu |- *.
  invertc Huu.
  intros p' uu2 Huu Hpq' <-.
  invertc Huu.
  intros m' u Hu Hmn' <-.
  apply seqctx_cons.
    {
    apply seqctx_cons; auto.
    simpsub.
    apply (seqhyp_tm _#5 (iutruncate (S j) (iuset stop A B))).
      {
      exploit (Hright1 j d u) as H; auto.
      rewrite -> qpromote_hyp_tm in H.
      simpsubin H.
      simpsub.
      invertc H.
      intros R Hsetl' Hsetu.
      so (basic_fun _#7 (basic_downward _#7 Hj Hsetl) Hsetl'); subst R.
      auto.
      }

      {
      apply (basic_downward _#3 i); auto.
      }

      {
      split; auto.
      cbn.
      simpsubin Hmn'.
      invertc Hmn'.
      intros R _ Har' Hmn'.
      so (basic_fun _#7 (basic_downward _#7 Hj Har) Har'); subst R.
      destruct Hmn' as (_ & Hmn').
      exists p, q, Hmn'.
      refine (rel_from_dist _#6 _ (urel_downward_leq _#6 Hj Hpq)).
      apply den_nonexpansive.
      apply (pi2 B).
      apply urelspinj_dist_diff; auto.
      eapply urel_downward_leq; eauto.
      }
    }

    {
    simpsub.
    invertc Hmn'.
    intros R _ Har' Hmn'.
    so (basic_fun _#7 (basic_downward _#7 Hj Har) Har'); subst R.
    destruct Hmn' as (_ & Hmn').
    invert Hbr.
    intros _ _ Hact.
    so (Hact _#3 Hj Hmn') as Hmblj; clear Hact.
    simpsubin Hmblj.
    simpsubin Hpq'.
    invertc Hpq'.
    intros R Hmbu Hmblj' Hpq'.
    so (basic_fun _#7 Hmblj Hmblj'); subst R.
    apply (seqhyp_tm _#5 (pi1 B' (urelspinj _#4 Hmn'))); auto.
    }
  }
Qed.

Lemma unit_urel_dist :
  forall i i' j,
    j <= i
    -> j <= i'
    -> @dist (wurel_ofe stop) (S j) (unit_urel stop i) (unit_urel stop i').
Proof.
intros i i' j Hji Hji'.
intros k Hk.
fextensionality 2.
intros m p.
cbn.
pextensionality.
  {
  intro H.
  decompose H.
  intros _ _ Hclm Hclp Hsteps Hsteps'.
  do2 5 split; auto.
  omega.
  }

  {
  intro H.
  decompose H.
  intros _ _ Hclm Hclp Hsteps Hsteps'.
  do2 5 split; auto.
  omega.
  }
Qed.

Lemma sound_squash_idem :
  forall G a b,
    pseq G (deqtype (set a b) (set a b))
    -> pseq G (deqtype (set a b) (set a (squash b))).
Proof.
intros G a b.
revert G.
refine (seq_pseq 1 [hyp_emp] b 1 [] _ _ _); cbn.
intros G Hclb Hseq.
rewrite -> seq_eqtype in Hseq |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
so (Hseq _#3 Hs) as (R & Hsetl & Hsetr & _).
exists R.
do2 2 split; auto.
simpsubin Hsetl.
simpsubin Hsetr.
simpsub.
invert (basic_value_inv _#6 value_set Hsetl).
intros A B Hal Hbl Heq1.
invert (basic_value_inv _#6 value_set Hsetr).
intros A' B' Har Hbr Heq2.
so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
clear Heq2.
subst R.
so (iuset_inj _#5 Heq); subst A'.
assert (den A = ceiling (S i) (den A)) as HeqA.
  {
  exact (f_equal den (basic_impl_iutruncate _#6 Hal)).
  }
set (Cf := fun (D : urelsp (den A) -n> siurel_ofe) x => iuset stop (iubase (unit_urel stop (urelsp_index _ x))) (semiconst_ne (unit_urel stop (urelsp_index _ x)) (pi1 D x))).
assert (forall D,
          @nonexpansive (urelsp (den A)) siurel_ofe (Cf D)) as Hne.
  {
  intros D j x y Hxy.
  destruct j as [| j].
    {
    apply dist_zero.
    }
  so (urelsp_eta _ _ x) as (k & m & p & Hmp & ->).
  so (urelsp_eta _ _ y) as (k' & n & q & Hnq & ->).
  unfold Cf.
  rewrite -> !urelsp_index_inj.
  so (urelspinj_dist_index' _#11 Hxy) as [(<- & Hkj) | (Hjk & Hjk')].
    {
    apply dist_refl'.
    do 3 f_equal.
    apply urelspinj_equal.
    so (urelspinj_dist_invert _#11 Hxy).
    rewrite -> Nat.min_r in H; auto.
    omega.
    }
  split; cbn -[dist].
    {
    intros j' Hj'.
    cbn.
    fextensionality 2.
    intros r t.
    pextensionality.
      {
      intro H.
      decompose H.
      intros u v Hrt Huv.
      rewrite -> urelsp_index_inj in Huv.
      exists u, v.
      assert (rel (unit_urel stop k') j' r t) as Hrt'.
        {
        refine (rel_from_dist _#6 _ Hrt).
        apply unit_urel_dist; omega.
        }
      exists Hrt'.
      rewrite -> urelsp_index_inj.
      force_exact Huv.
      f_equal.
      apply ceiling_collapse.
      apply den_nonexpansive.
      apply (pi2 D).
      apply urelspinj_dist_diff; try omega.
      so (urelspinj_dist_invert _#11 Hxy) as H.
      rewrite -> Nat.min_l in H; [| omega].
      apply (urel_downward_leq _#3 j); auto.
      omega.
      }

      {
      intro H.
      decompose H.
      intros u v Hrt Huv.
      rewrite -> urelsp_index_inj in Huv.
      exists u, v.
      assert (rel (unit_urel stop k) j' r t) as Hrt'.
        {
        refine (rel_from_dist _#6 _ Hrt).
        apply unit_urel_dist; omega.
        }
      exists Hrt'.
      rewrite -> urelsp_index_inj.
      force_exact Huv.
      f_equal.
      apply ceiling_collapse.
      apply den_nonexpansive.
      apply (pi2 D).
      apply urelspinj_dist_diff; try omega.
      so (urelspinj_dist_invert _#11 Hxy) as H.
      apply (urel_zigzag _#4 q m).
        {
        apply (urel_downward_leq _#3 k'); auto.
        omega.
        }

        {
        rewrite -> Nat.min_l in H; [| omega].
        apply (urel_downward_leq _#3 j); auto.
        omega.
        }

        {
        apply (urel_downward_leq _#3 k); auto.
        omega.
        }
      }
    }

    {
    apply meta_iurel_nonexpansive.
    split; cbn -[dist]; [| apply dist_refl].
    apply unit_urel_dist; omega.
    }
  }
set (C := fun D => ((expair (Cf D) (Hne D)) : urelsp (den A) -n> siurel_ofe)).
assert (forall D,
          iuset stop A D = iuset stop A (C D)) as Heq'.
  {
  intro D.
  apply prod_extensionality; cbn; auto.
  apply urel_extensionality.
  fextensionality 3.
  intros j m n.
  cbn.
  pextensionality.
    {
    intro H.
    decompose H.
    intros p q Hmn Hpq.
    exists triv, triv, Hmn.
    cbn.
    so (unit_urel_triv stop _ _ (le_refl j)) as Htriv.
    exists p, q.
    rewrite -> urelsp_index_inj.
    exists Htriv.
    rewrite -> !urelsp_index_inj.
    split; auto.
    }

    {
    intro H.
    decompose H.
    unfold semiconst_ne.
    cbn.
    intros p q Hmn Hpq.
    rewrite -> urelsp_index_inj in Hpq.
    decompose Hpq.
    intros r t Hpq Hrt.
    rewrite -> urelsp_index_inj in Hrt.
    exists r, t, Hmn.
    destruct Hrt as (_ & Hrt).
    exact Hrt.
    }
  }
split.
  {
  apply interp_eval_refl.
  rewrite -> Heq'.
  apply interp_set; auto.
  apply functional_i; auto.
    {
    eapply subst_closub_under_permit; eauto.
    unfold squash.
    prove_hygiene.
    }
  intros j m p Hj Hmp.
  unfold squash.
  simpsub.
  apply interp_eval_refl.
  apply interp_set.
    {
    apply interp_eval_refl.
    rewrite -> urelsp_index_inj.
    apply interp_unit.
    }
  rewrite -> urelsp_index_inj.
  apply functional_i.
    {
    eapply hygiene_subst; eauto.
    intros k Hk.
    destruct k as [| k]; simpsub.
      {
      apply hygiene_shift_permit; auto.
      exact (urel_closed _#5 Hmp andel).
      }

      {
      apply hygiene_shift_permit.
      eapply project_closub; eauto.
      }
    }

    {
    cbn.
    rewrite -> ceiling_unit.
    rewrite -> Nat.min_id.
    reflexivity.
    }
  intros j' q r Hj' Hqr.
  cbn.
  simpsub.
  invert Hbl.
  intros _ _ Hact.
  so (Hact _ _ _ (le_trans _#3 Hj' Hj) (urel_downward_leq _#6 Hj' Hmp)) as H.
  simpsubin H.
  so (basic_downward _#7 (le_refl _) H) as Hint; clear H.
  unfold semiconst.
  rewrite -> urelsp_index_inj.
  force_exact Hint.
  f_equal.
  apply iutruncate_collapse.
  apply (pi2 B).
  apply urelspinj_dist_diff; auto.
  eapply urel_downward_leq; eauto.
  }

  {
  rewrite -> Heq.
  apply interp_eval_refl.
  rewrite -> Heq'.
  apply interp_set; auto.
  apply functional_i; auto.
    {
    eapply subst_closub_under_permit; eauto.
    unfold squash.
    prove_hygiene.
    }
  intros j m p Hj Hmp.
  unfold squash.
  simpsub.
  apply interp_eval_refl.
  apply interp_set.
    {
    apply interp_eval_refl.
    rewrite -> urelsp_index_inj.
    apply interp_unit.
    }
  rewrite -> urelsp_index_inj.
  apply functional_i.
    {
    eapply hygiene_subst; eauto.
    intros k Hk.
    destruct k as [| k]; simpsub.
      {
      apply hygiene_shift_permit; auto.
      exact (urel_closed _#5 Hmp ander).
      }

      {
      apply hygiene_shift_permit.
      eapply project_closub; eauto.
      }
    }

    {
    cbn.
    rewrite -> ceiling_unit.
    rewrite -> Nat.min_id.
    reflexivity.
    }
  intros j' q r Hj' Hqr.
  cbn.
  simpsub.
  invert Hbr.
  intros _ _ Hact.
  so (Hact _ _ _ (le_trans _#3 Hj' Hj) (urel_downward_leq _#6 Hj' Hmp)) as H.
  simpsubin H.
  so (basic_downward _#7 (le_refl _) H) as Hint; clear H.
  unfold semiconst.
  rewrite -> urelsp_index_inj.
  force_exact Hint.
  f_equal.
  apply iutruncate_collapse.
  apply (pi2 B').
  apply urelspinj_dist_diff; auto.
  eapply urel_downward_leq; eauto.
  }
Qed.

Lemma sound_set_formation_invert :
  forall G a a' b b',
    pseq G (deqtype (set a b) (set a' b'))
    -> pseq G (deqtype a a').
Proof.
intros G a b c d.
revert G.
refine (seq_pseq 0 1 [] _ _ _).
cbn.
intros G Hseq.
rewrite -> seq_eqtype in Hseq |- *.
intros i s s' Hs.
so (Hseq _ _ _ Hs) as (R & Hacl & Hacr & Hbdl & Hbdr).
simpsubin Hacl.
invert (basic_value_inv _#6 value_set Hacl).
intros A B1 Hal _ Heq.
simpsubin Hacr.
invert (basic_value_inv _#6 value_set Hacr).
intros A' B2 Har _ Heq'.
so (eqtrans Heq (eqsymm Heq')) as H.
so (iuset_inj _#5 H); subst A'.
clear H Heq'.
simpsubin Hbdl.
invert (basic_value_inv _#6 value_set Hbdl).
intros A' B3 Hbl _ Heq'.
so (eqtrans Heq (eqsymm Heq')) as H.
so (iuset_inj _#5 H); subst A'.
clear H Heq'.
simpsubin Hbdr.
invert (basic_value_inv _#6 value_set Hbdr).
intros A' B4 Hbr _ Heq'.
so (eqtrans Heq (eqsymm Heq')) as H.
so (iuset_inj _#5 H); subst A'.
clear H Heq' Heq.
exists A.
auto.
Qed.


Require Import VST.concurrency.conclib.
Require Import VST.concurrency.ghosts.
Require Import VST.atomics.verif_lock.
Require Import VST.progs64.incr.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition spawn_spec := DECLARE _spawn spawn_spec.

Definition cptr_lock_inv g1 g2 ctr := EX z : Z, data_at Ews tuint (Vint (Int.repr z)) ctr *
  EX x : Z, EX y : Z, !!(z = x + y) && ghost_var gsh1 x g1 * ghost_var gsh1 y g2.

Definition incr_spec :=
 DECLARE _incr
  WITH sh : share, g1 : gname, g2 : gname, left : bool, n : Z, gv: globals
  PRE [ ]
         PROP  (readable_share sh)
         LOCAL (gvars gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 n (if left then g1 else g2))
  POST [ tvoid ]
         PROP ()
         LOCAL ()
         SEP (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 (n+1) (if left then g1 else g2)).

Definition read_spec :=
 DECLARE _read
  WITH sh : share, g1 : gname, g2 : gname, n1 : Z, n2 : Z, gv: globals
  PRE [ ]
         PROP  (readable_share sh)
         LOCAL (gvars gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 n1 g1; ghost_var gsh2 n2 g2)
  POST [ tuint ]
         PROP ()
         LOCAL (temp ret_temp (Vint (Int.repr (n1 + n2))))
         SEP (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 n1 g1; ghost_var gsh2 n2 g2).

Definition thread_lock_R sh g1 g2 ctr lockc :=
  lock_inv sh lockc (cptr_lock_inv g1 g2 ctr) * ghost_var gsh2 1 g1.

Definition thread_lock_inv sh g1 g2 ctr lockc lockt :=
  selflock (thread_lock_R sh g1 g2 ctr lockc) sh lockt.

Definition thread_func_spec :=
 DECLARE _thread_func
  WITH y : val, x : share * gname * gname * globals
  PRE [ _args OF (tptr tvoid) ]
         let '(sh, g1, g2, gv) := x in
         PROP  (readable_share sh)
         LOCAL (temp _args y; gvars gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr));
                ghost_var gsh2 0 g1;
                lock_inv sh (gv _thread_lock) (thread_lock_inv sh g1 g2 (gv _ctr) (gv _ctr_lock) (gv _thread_lock)))
  POST [ tptr tvoid ]
         PROP ()
         LOCAL ()
         SEP ().

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

Definition Gprog : funspecs :=   ltac:(with_library prog [acquire_spec; release_spec; release2_spec; makelock_spec;
  freelock_spec; freelock2_spec; spawn_spec; incr_spec; read_spec; thread_func_spec; main_spec]).

Lemma ctr_inv_exclusive : forall g1 g2 p,
  exclusive_mpred (cptr_lock_inv g1 g2 p).
Proof.
  intros; unfold cptr_lock_inv.
  eapply derives_exclusive, exclusive_sepcon1 with (Q := EX x : Z, EX y : Z, _),
    data_at__exclusive with (sh := Ews)(t := tuint); auto; simpl; try omega.
  Intro z; apply sepcon_derives; [cancel|].
  Intros x y; Exists x y; apply derives_refl.
Qed.
Hint Resolve ctr_inv_exclusive : exclusive.

Lemma thread_inv_exclusive : forall sh g1 g2 ctr lock lockt,
  exclusive_mpred (thread_lock_inv sh g1 g2 ctr lock lockt).
Proof.
  intros; apply selflock_exclusive.
  unfold thread_lock_R.
  apply exclusive_sepcon1; auto with exclusive.
Qed.
Hint Resolve thread_inv_exclusive : exclusive.

Lemma ghost_var_incr : forall g1 g2 x y n (left : bool), ghost_var gsh1 x g1 * ghost_var gsh1 y g2 * ghost_var gsh2 n (if left then g1 else g2) |--
  |==> !!((if left then x else y) = n) && ghost_var Tsh (n+1) (if left then g1 else g2) * ghost_var gsh1 (if left then y else x) (if left then g2 else g1).
Proof.
  destruct left.
  - rewrite sepcon_assoc, (sepcon_comm _ (ghost_var _ _ _)), <- sepcon_assoc.
    erewrite ghost_var_share_join' by eauto with share.
    Intros; rewrite prop_true_andp by auto; eapply derives_trans, bupd_frame_r; cancel.
    apply ghost_var_update.
  - erewrite sepcon_assoc, ghost_var_share_join' by eauto with share.
    Intros; rewrite prop_true_andp by auto; eapply derives_trans, bupd_frame_r; cancel.
    apply ghost_var_update.
Qed.

Lemma body_incr: semax_body Vprog Gprog f_incr incr_spec.
Proof.
  start_function.
  forward.
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  unfold cptr_lock_inv at 2; simpl.
  Intros z x y.
  forward.
  forward.
    eapply semax_pre_bupd.
first [apply SEP_entail'_bupd | apply SEP_entail']; go_lower.
   match goal with
   | |- ?R |-- ?R2 =>
         let r2 := fresh "R2" in
         pose (r2 := R2); change_no_check (R |-- r2) end.

let x := fresh g1 in
  unshelve evar ( x : gname ); revgoals; [ let x' := eval unfold x in x in
                                       idtac |].
let x := fresh g2 in
  unshelve evar ( x : gname ); revgoals; [ let x' := eval unfold x in x in
                                       idtac |].
let x := fresh x in
  unshelve evar ( x : Z ); revgoals; [ let x' := eval unfold x in x in
                                       idtac x'|].
let x := fresh y in
  unshelve evar ( x : Z ); revgoals; [ let x' := eval unfold x in x in
                                       idtac |].
let x := fresh n in
  unshelve evar ( x : Z ); revgoals; [ let x' := eval unfold x in x in
                                       idtac |].
let x := fresh left in
  unshelve evar ( x : bool ); revgoals; [ let x' := eval unfold x in x in
                                       idtac |].
let H' := adjust2_sep_apply (ghost_var_incr ?g0 ?g3 ?x0 ?y0 ?n0 ?left0) in
match type of H' with
  | ?TH =>
      match apply_find_core TH with
      | ?C |-- ?D => idtac "1";
          let frame := fresh "frame" in
          evar ( frame : list mpred ); apply derives_trans with (C * fold_right_sepcon frame)(*;
           [ solve
           [ cancel_for_sep_apply ]
           | eapply derives_trans;
              [ apply sepcon_derives; [ clear frame; apply H' | apply derives_refl ]
              | let x := fresh "x" in
                set (x := fold_right_sepcon frame); subst frame; unfold fold_right_sepcon in x; subst x;
                 rewrite ?sepcon_emp ] ]*)
      end
  end.
ecancel.
(* This should be solvable with ecancel! *)
  gather_SEP 2 3 4.
  viewshift_SEP 0 (!!((if left then x else y) = n) && ghost_var Tsh (n+1) (if left then g1 else g2) *
    ghost_var gsh1 (if left then y else x) (if left then g2 else g1)).
  { go_lower.
    destruct left.
    - rewrite (sepcon_comm _ (ghost_var _ _ _)), <- sepcon_assoc.
      erewrite ghost_var_share_join' by eauto with share.
      Intros; rewrite prop_true_andp by auto; eapply derives_trans, bupd_frame_r; cancel.
      apply ghost_var_update.
    - erewrite ghost_var_share_join' by eauto with share.
      Intros; rewrite prop_true_andp by auto; eapply derives_trans, bupd_frame_r; cancel.
      apply ghost_var_update. }
  Intros; forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  { lock_props.
    unfold cptr_lock_inv; Exists (z + 1).
    rewrite <- (ghost_var_share_join gsh1 gsh2) by auto with share.
    unfold Frame; instantiate (1 := [ghost_var gsh2 (n+1) (if left then g1 else g2)]); simpl.
    destruct left.
    - Exists (n+1) y; entailer!.
    - Exists x (n+1); entailer!. }
  forward.
Qed.

Lemma body_read : semax_body Vprog Gprog f_read read_spec.
Proof.
  start_function.
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  unfold cptr_lock_inv at 2; simpl.
  Intros z x y.
  forward.
  assert_PROP (x = n1 /\ y = n2) as Heq.
  { gather_SEP 2 4.
    erewrite ghost_var_share_join' by eauto with share.
    gather_SEP 3 4.
    erewrite ghost_var_share_join' by eauto with share.
    entailer!. }
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  { lock_props.
    unfold cptr_lock_inv; Exists z x y; entailer!. }
  destruct Heq; forward.
Qed.

Lemma body_thread_func : semax_body Vprog Gprog f_thread_func thread_func_spec.
Proof.
  start_function.
  Intros.
  forward.
  forward_call (sh, g1, g2, true, 0, gv).
  simpl.
  forward_call ((gv _thread_lock), sh, thread_lock_R sh g1 g2 (gv _ctr) (gv _ctr_lock), thread_lock_inv sh g1 g2 (gv _ctr) (gv _ctr_lock) (gv _thread_lock)).
  { lock_props.
    unfold thread_lock_inv, thread_lock_R.
    rewrite selflock_eq at 2; cancel. }
  forward.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  set (ctr := gv _ctr); set (lockt := gv _thread_lock); set (lock := gv _ctr_lock).
  forward.
  forward.
  forward.
  ghost_alloc (ghost_var Tsh 0).
  Intro g1.
  ghost_alloc (ghost_var Tsh 0).
  Intro g2.
  forward_call (lock, Ews, cptr_lock_inv g1 g2 ctr).
  forward_call (lock, Ews, cptr_lock_inv g1 g2 ctr).
  { lock_props.
    rewrite <- !(ghost_var_share_join gsh1 gsh2 Tsh) by auto with share.
    unfold cptr_lock_inv; Exists 0 0 0; entailer!. }
  (* need to split off shares for the locks here *)
  destruct split_Ews as (sh1 & sh2 & ? & ? & Hsh).
  forward_call (lockt, Ews, thread_lock_inv sh1 g1 g2 ctr lock lockt).
  forward_spawn _thread_func nullval (sh1, g1, g2, gv).
  { erewrite <- lock_inv_share_join; try apply Hsh; auto.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto.
    subst ctr lock lockt; entailer!. }
  forward_call (sh2, g1, g2, false, 0, gv).
  forward_call (lockt, sh2, thread_lock_inv sh1 g1 g2 ctr lock lockt).
  { subst ctr lock lockt; cancel. }
  unfold thread_lock_inv at 2; unfold thread_lock_R.
  rewrite selflock_eq.
  Intros.
  simpl.
  forward_call (sh2, g1, g2, 1, 1, gv).
  (* We've proved that t is 2! *)
  forward_call (lock, sh2, cptr_lock_inv g1 g2 ctr).
  { subst ctr lock; cancel. }
  forward_call (lockt, Ews, sh1, thread_lock_R sh1 g1 g2 ctr lock, thread_lock_inv sh1 g1 g2 ctr lock lockt).
  { lock_props.
    unfold thread_lock_inv, thread_lock_R.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto; subst ctr lock; cancel. }
  forward_call (lock, Ews, cptr_lock_inv g1 g2 ctr).
  { lock_props.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto; subst lock ctr; cancel. }
  forward.
Qed.

Definition extlink := ext_link_prog prog.
Definition Espec := add_funspecs (Concurrent_Espec unit _ extlink) extlink Gprog.
#[export] Existing Instance Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
repeat (apply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | ]).
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons body_incr.
semax_func_cons body_read.
semax_func_cons body_thread_func.
semax_func_cons body_main.
Qed.