Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * A general [fold] over grammars *)
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.BaseTypesLemmas.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.ContextFreeGrammar.Precompute.
Require Import Fiat.Common.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.OptionFacts.

Set Implicit Arguments.

Section general_fold.
  Context {Char : Type} {T : Type}.

  Class fold_grammar_data :=
    { on_terminal : (Char -> bool) -> T;
      on_redundant_nonterminal : String.string -> T;
      on_nonterminal : String.string -> T -> T;
      on_nil_production : T;
      combine_production : T -> T -> T;
      on_nil_productions : T;
      combine_productions : T -> T -> T }.
  Context `{fold_grammar_data} (G : pregrammar' Char).

  Global Instance compile_item_data_of_fold_grammar_data : opt.compile_item_data Char T
    := {| opt.on_terminal := on_terminal;
          opt.nonterminal_names := pregrammar_nonterminals G;
          opt.invalid_nonterminal := Gensym.gensym (pregrammar_nonterminals G) |}.

  Section with_compiled_productions.
    Context (compiled_productions : list (opt.productions T))
            (Hcompiled_productions : List.map opt.compile_productions (List.map snd (pregrammar_productions G)) = compiled_productions).

    Definition opt_Lookup_idx (n : nat) : opt.productions T
      := List.nth n compiled_productions nil.
    Lemma eq_opt_Lookup_idx n
      : opt_Lookup_idx n = opt.compile_productions (Lookup_idx G n).
    Proof.
      unfold opt_Lookup_idx, Lookup_idx; subst compiled_productions.
      change nil with (opt.compile_productions nil) at 1.
      rewrite map_nth.
      reflexivity.
    Qed.

    Definition fold_production' (fold_nt : String.string -> default_nonterminal_carrierT -> T)
               (its : opt.production T)
      := fold_right
           combine_production
           on_nil_production
           (map
              (fun it =>
                 match it with
                 | opt.Terminal ch => ch
                 | opt.NonTerminal nt nt_idx => on_nonterminal nt (fold_nt nt nt_idx)
                 end)
              its).

    Lemma fold_production'_ext {f g} (ext : forall b b', f b b' = g b b') b
      : fold_production' f b = fold_production' g b.
    Proof.
      unfold fold_production'.
      induction b as [ | x ]; try reflexivity; simpl.
      destruct x; rewrite ?IHb, ?ext; reflexivity.
    Qed.

    Definition fold_productions' (fold_nt : String.string -> default_nonterminal_carrierT -> T)
               (its : opt.productions T)
      := fold_right
           combine_productions
           on_nil_productions
           (map
              (fold_production' fold_nt)
              its).

    Lemma fold_productions'_ext {f g} (ext : forall b b', f b b' = g b b') b
      : fold_productions' f b = fold_productions' g b.
    Proof.
      unfold fold_productions'.
      induction b as [ | x ]; try reflexivity; simpl.
      rewrite IHb, (fold_production'_ext ext); reflexivity.
    Qed.

    Definition fold_nt_step
               (predata := @rdp_list_predata _ G)
               (valid0_len : nat)
               (fold_nt : forall valid_len : nat,
                   nonterminals_listT
                   -> String.string -> default_nonterminal_carrierT -> T)
               (valid0 : nonterminals_listT)
               (nt : String.string)
               (nt_idx : default_nonterminal_carrierT)
      : T.
    Proof.
      refine match valid0_len with
             | 0 => on_redundant_nonterminal nt
             | S valid0_len'
               => if is_valid_nonterminal valid0 nt_idx
                  then fold_productions'
                         (@fold_nt valid0_len' (remove_nonterminal valid0 nt_idx))
                         (opt_Lookup_idx nt_idx)
                  else on_redundant_nonterminal nt
             end.
    Defined.

    Lemma fold_nt_step_ext
          {x0 x0' f g}
          (ext : forall y p b b', f y p b b' = g y p b b')
          b b'
      : @fold_nt_step x0 f x0' b b' = @fold_nt_step x0 g x0' b b'.
    Proof.
      unfold fold_nt_step.
      repeat match goal with
             | [ |- context[match ?x with _ => _ end] ]
               => destruct x eqn:?
             | _ => reflexivity
             end.
      apply fold_productions'_ext; eauto.
    Qed.

    Fixpoint fold_cnt' initial : nonterminals_listT -> String.string -> default_nonterminal_carrierT -> T
      := @fold_nt_step initial (@fold_cnt').

    Lemma unfold_fold_cnt' initial
      : @fold_cnt' initial = @fold_nt_step initial (@fold_cnt').
    Proof. destruct initial; reflexivity. Qed.

    Definition fold_cnt : String.string -> default_nonterminal_carrierT -> T
      := let predata := @rdp_list_predata _ G in
         @fold_cnt' (nonterminals_length initial_nonterminals_data) initial_nonterminals_data.
    Definition fold_nt' initial (valid0 : nonterminals_listT) (nt : String.string) : T
      := @fold_cnt' initial valid0 nt (opt.compile_nonterminal nt).

    Definition fold_nt : String.string -> T
      := let predata := @rdp_list_predata _ G in
         @fold_nt' (nonterminals_length initial_nonterminals_data) initial_nonterminals_data.

    Definition fold_production (pat : production Char) : T
      := @fold_production' (@fold_cnt) (opt.compile_production pat).

    Definition fold_productions (pats : productions Char) : T
      := @fold_productions' (@fold_cnt) (opt.compile_productions pats).
  End with_compiled_productions.

  Definition compiled_productions : list (opt.productions T)
    := List.map opt.compile_productions (List.map snd (pregrammar_productions G)).
End general_fold.
Global Hint Immediate compile_item_data_of_fold_grammar_data : typeclass_instances.

Global Arguments fold_grammar_data : clear implicits.

Section fold_correctness.
  Context {Char : Type} {T : Type}.
  Context {FGD : fold_grammar_data Char T}
          (G : pregrammar' Char).

  Let predata := @rdp_list_predata _ G.
  Local Existing Instance predata.

  Class fold_grammar_correctness_computational_data :=
    { Pnt : nonterminals_listT -> String.string -> T -> Type;
      Ppat : nonterminals_listT -> production Char -> T -> Type;
      Ppats : nonterminals_listT -> productions Char -> T -> Type }.
  Class fold_grammar_correctness_data :=
    { fgccd :> fold_grammar_correctness_computational_data;
      Pnt_lift : forall valid0 nt value,
                   sub_nonterminals_listT valid0 initial_nonterminals_data
                   -> is_valid_nonterminal valid0 (of_nonterminal nt)
                   -> Ppats (remove_nonterminal valid0 (of_nonterminal nt)) (G nt) value
                   -> Pnt valid0 nt value;
      Pnt_redundant : forall valid0 nt,
                        sub_nonterminals_listT valid0 initial_nonterminals_data
                        -> is_valid_nonterminal valid0 (of_nonterminal nt) = false
                        -> Pnt valid0 nt (on_redundant_nonterminal nt);
      Ppat_nil : forall valid0, Ppat valid0 nil on_nil_production;
      Ppat_cons_nt : forall valid0 nt xs p ps,
                       sub_nonterminals_listT valid0 initial_nonterminals_data
                       -> Pnt valid0 nt p
                       -> Ppat valid0 xs ps
                       -> Ppat valid0
                               (NonTerminal nt::xs)
                               (combine_production (on_nonterminal nt p) ps);
      Ppat_cons_t : forall valid0 ch xs ps,
                      sub_nonterminals_listT valid0 initial_nonterminals_data
                      -> Ppat valid0 xs ps
                      -> Ppat valid0
                              (Terminal ch::xs)
                              (combine_production (on_terminal ch) ps);
      Ppats_nil : forall valid0, Ppats valid0 nil on_nil_productions;
      Ppats_cons : forall valid0 x xs p ps,
                     sub_nonterminals_listT valid0 initial_nonterminals_data
                     -> Ppat valid0 x p
                     -> Ppats valid0 xs ps
                     -> Ppats valid0 (x::xs) (combine_productions p ps) }.
  Context {FGCD : fold_grammar_correctness_data}.

  Lemma fold_production'_correct
        valid0
        f
        (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
        (IHf : forall nt nt_idx, of_nonterminal nt = nt_idx -> Pnt valid0 nt (f nt nt_idx))
        pat
  : Ppat valid0 pat (fold_production' f (opt.compile_production pat)).
  Proof.
    unfold fold_production'.
    induction pat; simpl.
    { apply Ppat_nil. }
    { edestruct (_ : item _).
      { apply Ppat_cons_t; trivial. }
      { apply Ppat_cons_nt; eauto. } }
  Qed.

  Lemma fold_productions'_correct
        valid0
        f
        (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
        (IHf : forall nt nt_idx, of_nonterminal nt = nt_idx -> Pnt valid0 nt (f nt nt_idx))
        pats
  : Ppats valid0 pats (fold_productions' f (opt.compile_productions pats)).
  Proof.
    unfold fold_productions'.
    induction pats as [ | x xs IHxs ]; intros.
    { simpl; apply Ppats_nil. }
    { simpl; apply Ppats_cons; trivial; [].
      { apply fold_production'_correct; trivial. } }
  Qed.

  Section step.
    Context (fold_nt : forall valid_len : nat,
                         nonterminals_listT
                         -> String.string -> default_nonterminal_carrierT -> T).

    Lemma fold_nt_step_correct0
          (valid0 : nonterminals_listT)
          (Hlen : nonterminals_length valid0 <= 0)
          (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
      : forall nt nt_idx,
        of_nonterminal nt = nt_idx
        -> Pnt valid0 nt (fold_nt_step (compiled_productions G) 0 fold_nt valid0 nt nt_idx).
    Proof.
      assert (Hlen' : nonterminals_length valid0 = 0) by omega; clear Hlen.
      simpl; intros nt nt_idx Hnt.
      apply Pnt_redundant; [ assumption | ].
      destruct (is_valid_nonterminal valid0 (of_nonterminal nt)) eqn:Hvalid; trivial.
      assert (nonterminals_length (remove_nonterminal valid0 (of_nonterminal nt)) < nonterminals_length valid0)
        by (apply remove_nonterminal_dec; assumption).
      omega.
    Qed.
  End step.

  Local Opaque rdp_list_predata.

  Lemma fold_cnt'_correct
        (valid0 : nonterminals_listT)
        (valid0_len : nat)
        (Hlen : nonterminals_length valid0 <= valid0_len)
        (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
    : forall nt nt_idx,
      of_nonterminal nt = nt_idx
      -> Pnt valid0 nt (fold_cnt' (compiled_productions G) valid0_len valid0 nt nt_idx).
  Proof.
    revert valid0 Hsub Hlen.
    induction valid0_len as [|valid0_len IH].
    { intros; apply fold_nt_step_correct0; assumption. }
    { simpl.
      intros valid0 Hsub Hlen nt nt_idx Hnt.
      match goal with
        | [ |- context[if ?e then _ else _] ] => destruct e eqn:Hvalid
      end.
      { apply Pnt_lift; [ subst; assumption.. | ].
        rewrite (eq_opt_Lookup_idx G), <- list_to_productions_to_nonterminal by reflexivity.
        change (Lookup_string G) with (Lookup G); subst.
        change default_to_nonterminal with to_nonterminal.
        rewrite to_of_nonterminal
          by (apply initial_nonterminals_correct, Hsub; assumption).
        apply fold_productions'_correct.
        { apply sub_nonterminals_listT_remove_2; assumption. }
        { apply IH.
          { apply sub_nonterminals_listT_remove_2; assumption. }
          { apply Le.le_S_n.
            etransitivity; [ | exact Hlen ].
            apply (remove_nonterminal_dec valid0 (of_nonterminal nt) Hvalid). } } }
      { apply Pnt_redundant; subst; assumption. } }
  Qed.

  Lemma fold_cnt_correct
        nt nt_idx
        (Hnt : of_nonterminal nt = nt_idx)
  : Pnt initial_nonterminals_data nt (fold_cnt G (compiled_productions G) nt nt_idx).
  Proof.
    unfold fold_cnt.
    apply fold_cnt'_correct; subst; reflexivity.
  Qed.

  Lemma fold_nt'_correct
        (valid0 : nonterminals_listT)
        (valid0_len : nat)
        (Hlen : nonterminals_length valid0 <= valid0_len)
        (Hsub : sub_nonterminals_listT valid0 initial_nonterminals_data)
    : forall nt, Pnt valid0 nt (fold_nt' (compiled_productions G) valid0_len valid0 nt).
  Proof.
    intro nt; apply fold_cnt'_correct; auto.
  Qed.

  Lemma fold_nt_correct
        nt
  : Pnt initial_nonterminals_data nt (fold_nt G (compiled_productions G) nt).
  Proof.
    unfold fold_nt.
    apply fold_nt'_correct;
    reflexivity.
  Qed.

  Lemma fold_production_correct
        pat
  : Ppat initial_nonterminals_data pat (fold_production G (compiled_productions G) pat).
  Proof.
    unfold fold_production.
    apply fold_production'_correct, fold_cnt_correct.
    reflexivity.
  Qed.

  Lemma fold_productions_correct
        pats
  : Ppats initial_nonterminals_data pats (fold_productions G (compiled_productions G) pats).
  Proof.
    unfold fold_productions.
    apply fold_productions'_correct, fold_cnt_correct.
    reflexivity.
  Qed.
End fold_correctness.

Module compile.
  Section semantics.
    Context {Char : Type} {T : Type}.
    Context `{@fold_grammar_data Char T} (G : pregrammar' Char).

    Local Notation productions_def precompiled_productions
      := (List.map (fun nt_idx_nt => fold_cnt G precompiled_productions (snd nt_idx_nt) (fst nt_idx_nt)) (enumerate (List.map fst (pregrammar_productions G)) 0)).

    Definition productions : list T
      := productions_def (compiled_productions G).

    Section with_compiled_productions.
      Context (precompiled_productions : list (opt.productions T))
              (Hprecompiled_productions : List.map opt.compile_productions (List.map snd (pregrammar_productions G)) = precompiled_productions).
      Context (compiled_productions : list T)
              (Hcompiled_productions : productions_def precompiled_productions = compiled_productions).

      Definition fold_cnt : String.string -> default_nonterminal_carrierT -> T
        := fun nt nt_idx => List.nth nt_idx compiled_productions (on_redundant_nonterminal nt).
      Definition fold_nt : String.string -> T
        := fun nt => fold_cnt nt (opt.compile_nonterminal nt).
      Definition fold_production (pat : Core.production Char) : T
        := fold_production' fold_cnt (opt.compile_production pat).
      Definition fold_productions (pats : Core.productions Char) : T
        := fold_productions' fold_cnt (opt.compile_productions pats).
    End with_compiled_productions.

  End semantics.

  Section fold_correctness.
    Context {Char : Type} {T : Type}.
    Context {FGD : fold_grammar_data Char T}
            (G : pregrammar' Char)
            {FGCD : fold_grammar_correctness_data G}.

    Let predata := @rdp_list_predata _ G.
    Local Existing Instance predata.

    Lemma fold_cnt_correct
          nt nt_idx
          (Hnt : of_nonterminal nt = nt_idx)
      : Pnt initial_nonterminals_data nt (fold_cnt (productions G) nt nt_idx).
    Proof.
      unfold fold_cnt, productions.
      repeat match goal with
             | _ => progress subst
             | _ => rewrite ListFacts.nth_error_nth
             | _ => progress unfold option_map in *
             | _ => progress break_innermost_match_step
             | _ => progress break_innermost_match_hyps_step
             | _ => progress inversion_option
             | _ => progress destruct_head' sig
             | _ => progress destruct_head' and
             | _ => progress cbn [fst snd plus] in *
             | [ H : nth_error (map _ _) _ = Some _ |- _ ] => apply ListFacts.nth_error_map'_strong in H
             | [ H : nth_error (enumerate _ _) _ = _ |- _ ]
               => rewrite ListFacts.nth_error_enumerate in H
             | [ H : nth_error (map ?f ?ls) ?idx = None |- _ ]
               => let H' := fresh in
                  destruct (nth_error ls idx) eqn:H';
                    [ eapply map_nth_error in H'; rewrite H in H'; congruence
                    | clear H ]
             end.
      { match goal with
        | [ H : nth_error _ (of_nonterminal ?nt) = Some ?x |- _ ]
          => assert (fst x = nt);
               [ pose proof H as H'; rewrite nth_error_default_to_nonterminal in H'
               | subst nt ]
        end.
        { break_innermost_match_hyps; try congruence; inversion_option; subst.
          cbn [fst].
          change default_to_nonterminal with (rdp_list_to_nonterminal (G:=G)).
          unfold of_nonterminal, predata, rdp_list_predata.
          rewrite rdp_list_to_of_nonterminal; [ reflexivity | ].
          apply initial_nonterminals_correct, rdp_list_is_valid_nonterminal_nth_error.
          congruence. }
        { apply fold_cnt_correct; reflexivity. } }
      { apply Pnt_redundant; [ reflexivity | ].
        match goal with |- ?x = false => destruct x eqn:Hb end;
          [ | reflexivity ].
        exfalso.
        eapply rdp_list_is_valid_nonterminal_nth_error; try eassumption; assumption. }
    Qed.

    Lemma fold_nt_correct nt
      : Pnt initial_nonterminals_data nt (fold_nt G (productions G) nt).
    Proof. unfold fold_nt; apply fold_cnt_correct; reflexivity. Qed.

    Lemma fold_production_correct pat
      : Ppat initial_nonterminals_data pat (fold_production G (productions G) pat).
    Proof.
      unfold fold_production.
      apply fold_production'_correct; [ reflexivity | apply fold_cnt_correct ].
    Qed.

    Lemma fold_productions_correct pats
      : Ppats initial_nonterminals_data pats (fold_productions G (productions G) pats).
    Proof.
      unfold fold_productions.
      apply fold_productions'_correct; [ reflexivity | apply fold_cnt_correct ].
    Qed.
  End fold_correctness.
End compile.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs64.object.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope Z.
Local Open Scope logic.

Definition object_invariant := list Z -> val -> mpred.

Definition tobject := tptr (Tstruct _object noattr).

Definition reset_spec (instance: object_invariant) :=
  WITH self: val, history: list Z
  PRE [ _self OF tobject]
          PROP ()
          LOCAL (temp _self self)
          SEP (instance history self)
  POST [ tvoid ]
          PROP() LOCAL () SEP(instance nil self).

Definition twiddle_spec (instance: object_invariant) :=
  WITH self: val, i: Z, history: list Z
  PRE [ _self OF tobject, _i OF tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 history <= Int.max_signed / 4)
          LOCAL (temp _self self; temp _i (Vint (Int.repr i)))
          SEP (instance history self)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 history < v <= 2* fold_right Z.add 0 (i::history))
          LOCAL (temp ret_temp (Vint (Int.repr v)))
          SEP(instance (i::history) self).

Definition object_methods (instance: object_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val,
  !! readable_share sh &&
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset,twiddle) mtable.

Lemma object_methods_local_facts: forall instance p,
  object_methods instance p |-- !! isptr p.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.
entailer!.
Qed.
Hint Resolve object_methods_local_facts : saturate_local.

Definition object_mpred (history: list Z) (self: val) : mpred :=
  EX instance: object_invariant, EX mtable: val,
       (object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self*
     instance history self).

Definition foo_invariant : object_invariant :=
  (fun (history: list Z) p =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 history)))) p
      *  malloc_token Ews (Tstruct _foo_object noattr) p).

Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () LOCAL (gvars gv)
    SEP (mem_mgr gv; object_methods foo_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () LOCAL (temp ret_temp p)
     SEP (mem_mgr gv; object_mpred nil p; object_methods foo_invariant (gv _foo_methods)).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog nil gv
  POST [ tint ]
     EX i:Z, PROP(0<=i<=6) LOCAL (temp ret_temp (Vint (Int.repr i))) SEP(TT).

Definition Gprog : funspecs :=   ltac:(with_library prog [
    foo_reset_spec; foo_twiddle_spec; make_foo_spec; main_spec]).

Lemma object_mpred_i:
  forall (history: list Z) (self: val) (instance: object_invariant) (mtable: val),
    object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self *
     instance history self
    |-- object_mpred history self.
Proof.
intros. unfold object_mpred. Exists instance mtable; auto.
Qed.

Lemma body_foo_reset: semax_body Vprog Gprog f_foo_reset foo_reset_spec.
Proof.
unfold foo_reset_spec, foo_invariant, reset_spec.
start_function.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
forward.  (* return; *)
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_twiddle: semax_body Vprog Gprog f_foo_twiddle foo_twiddle_spec.
Proof.
unfold foo_twiddle_spec, foo_invariant, twiddle_spec.
start_function.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
forward.  (* return d+i; *)
simpl.
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
Exists (2 * fold_right Z.add 0 history + i).
simpl;
entailer!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!.
Qed.

Lemma split_object_methods:
  forall instance m,
    object_methods instance m |-- object_methods instance m * object_methods instance m.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.

Exists (fst (slice.cleave sh)) reset twiddle.
Exists (snd (slice.cleave sh)) reset twiddle.
rewrite (split_func_ptr' (reset_spec instance) reset) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddle) at 1.
entailer!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

Lemma body_make_foo: semax_body Vprog Gprog f_make_foo make_foo_spec.
Proof.
unfold make_foo_spec.
start_function.
forward_call (Tstruct _foo_object noattr, gv).
   split3; simpl; auto; computable.
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _foo_object noattr) p;
          data_at_ Ews (Tstruct _foo_object noattr) p;
          object_methods foo_invariant (gv _foo_methods))).
*
change (Memory.EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!.
*
forward_call tt.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &foo_methods; *)
forward. (* p->data = 0; *)
forward. (* return (struct object * ) p; *)
Exists p.
unfold object_mpred.
Exists foo_invariant (gv _foo_methods).
sep_apply (split_object_methods foo_invariant (gv _foo_methods)).
unfold foo_invariant at 4.
entailer!.
simpl.
unfold_data_at (field_at _ _ nil _ p).
cancel.
unfold withspacer; simpl.
rewrite !field_at_data_at.
simpl.
apply derives_refl'.
rewrite <- ?sepcon_assoc. (* needed if Archi.ptr64=true *)
rewrite !field_compatible_field_address; auto with field_compatible.
clear - H.
(* TODO: simplify the following proof. *)
destruct p; try contradiction.
destruct H as [AL SZ].
repeat split; auto.
simpl in *; omega.
eapply align_compatible_rec_Tstruct; [reflexivity |].
simpl co_members; intros.
simpl in H.
if_tac in H; [| inv H].
inv H. inv H0.
eapply align_compatible_rec_by_value.
reflexivity.
rewrite Z.add_0_r.
simpl.
unfold natural_alignment in AL.
eapply Z.divide_trans; [ | apply AL].
apply prove_Zdivide.
reflexivity.
left; auto.
Qed.

Lemma make_object_methods:
  forall sh instance reset twiddle mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset, twiddle) mtable
  |-- object_methods instance mtable.
Proof.
  intros.
  unfold object_methods.
  Exists sh reset twiddle.
  entailer!.
Qed.

Ltac method_call witness hist' result :=
repeat apply seq_assoc1;
match goal with
   |- semax _ (PROPx _ (LOCALx ?Q (SEPx ?R)))
            (Ssequence (Sset ?mt (Efield (Ederef (Etempvar ?x _)  _) _ _))
                 _) _  =>
    match Q with context [temp ?x ?x'] =>
     match R with context [object_mpred _ x'] =>
          let instance := fresh "instance" in let mtable := fresh "mtable" in
          unfold object_mpred; Intros instance mtable;
          forward;
          unfold object_methods at 1;
          let sh := fresh "sh" in let r := fresh "r" in let t := fresh "t" in
          Intros sh r t;
          forward;
          forward_call witness;
          [ .. | try Intros result;
                  sep_apply (make_object_methods sh instance r t mtable); [ auto .. | ];
                  sep_apply (object_mpred_i hist' x' instance mtable);
                  deadvars; try clear dependent sh; try clear r; try clear t
           ]
    end end
end.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
(* assert_gvar _foo_methods. (* TODO: this is needed for a field_compatible later on *) *)
fold noattr cc_default.
(* 0. This part should be handled automatically by start_function *)
gather_SEP 1 2;
replace_SEP 0 (data_at Ews (Tstruct _methods noattr)
   (gv _foo_reset, gv _foo_twiddle) (gv _foo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _methods _) _ (gv _foo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite field_at_data_at.  rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  cancel.
}

(* 1. Prove that [mtable] is a proper method-table for foo-objects *)

make_func_ptr _foo_twiddle.
make_func_ptr _foo_reset.
sep_apply (make_object_methods Ews foo_invariant(gv _foo_reset) (gv _foo_twiddle) (gv _foo_methods)); auto.

(* 2. Build an instance of class [foo], called [p] *)
forward_call (* p = make_foo(); *)
        gv.
Intros p.

(* 3. Done with object_methods for the foreseeable future *)
freeze [2]  MT.
 gather_SEP 1.

(* Illustration of an alternate method to prove the method calls.
   Method 1:  comment out lines AA and BB and the entire range CC-DD.
   Method 2:  comment out lines AA-BB, inclusive.
*)

(* AA *) try (tryif
  (method_call (p, @nil Z) (@nil Z) whatever;
   method_call (p, 3, @nil Z) [3%Z] i;
     [simpl; computable | ])
(* BB *)  then fail else fail 99)
  .

(* CC *)
(* 4. first method-call *)
unfold object_mpred.
Intros instance mtable0.
forward. (*  mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward. (* p_reset = mtable->reset; *)
forward_call (* p_reset(p); *)
      (p, @nil Z).
(* Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).
deadvars!. clear.

(* 5. second method-call *)
unfold object_mpred.
Intros instance mtable0.
forward.  (* mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward.   (* p_twiddle = mtable->twiddle; *)
forward_call (* i = p_twiddle(p,3); *)
      (p, 3, @nil Z).
  simpl. computable.
Intros i.
simpl in H0.
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [3] p instance mtable0).
deadvars!. clear - H0.

(* DD *)

(* 6. return *)
forward.  (* return i; *)
Exists i; entailer!.
Qed.


Require Import GhostSimulations.

Require Import Raft.
Require Import RaftRefinementInterface.
Require Import CommonTheorems.
Require Import SpecLemmas.
Require Import RefinementSpecLemmas.
Require Import RefinementCommonTheorems.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import LeaderLogsVotesWithLogInterface.
Require Import VotesCorrectInterface.
Require Import CroniesCorrectInterface.
Require Import VotesVotesWithLogCorrespondInterface.
Require Import LeaderLogsTermSanityInterface.
Require Import OneLeaderLogPerTermInterface.

Section OneLeaderLogPerTerm.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.
  Context {rri : raft_refinement_interface}.

  Context {llvwli : leaderLogs_votesWithLog_interface}.
  Context {vci : votes_correct_interface}.
  Context {cci : cronies_correct_interface}.
  Context {vvci : votes_votesWithLog_correspond_interface}.
  Context {lltsi : leaderLogs_term_sanity_interface}.

  Ltac update_destruct :=
    match goal with
      | [ |- context [ update _ ?y _ ?x ] ] => destruct (name_eq_dec y x)
      | [ H : context [ update _ ?y _ ?x ] |- _ ] => destruct (name_eq_dec y x)
    end.

  Ltac start :=
    red; unfold one_leaderLog_per_term; simpl; intros.

  Ltac start_update :=
    start;
    repeat find_higher_order_rewrite;
    repeat (update_destruct; subst; rewrite_update);
    [| | |eauto].

  Lemma one_leaderLog_per_term_init :
    refined_raft_net_invariant_init one_leaderLog_per_term.
  Proof using.
    start. contradiction.
  Qed.

  Lemma one_leaderLog_per_term_unchanged :
    forall net st' ps' h gd d,
      one_leaderLog_per_term net ->
      (forall h' : Net.name, st' h' = update (nwState net) h (gd, d) h') ->
      leaderLogs gd = leaderLogs (fst (nwState net h)) ->
      one_leaderLog_per_term {| nwPackets := ps'; nwState := st' |}.
  Proof using.
    unfold one_leaderLog_per_term. intros.
    repeat find_higher_order_rewrite;
    repeat (update_destruct; subst; rewrite_update);
    simpl in *; repeat find_rewrite; eauto.
  Qed.

  Ltac start_unchanged :=
    red; intros; eapply one_leaderLog_per_term_unchanged; eauto; subst.

  (* solve invariant by lemma which shows leader logs do not change *)
  Ltac unchanged lem :=
    start_unchanged; apply lem.

  Lemma one_leaderLog_per_term_client_request :
    refined_raft_net_invariant_client_request one_leaderLog_per_term.
  Proof using.
    unchanged update_elections_data_client_request_leaderLogs.
  Qed.

  Lemma one_leaderLog_per_term_timeout :
    refined_raft_net_invariant_timeout one_leaderLog_per_term.
  Proof using.
    unchanged update_elections_data_timeout_leaderLogs.
  Qed.

  Lemma one_leaderLog_per_term_append_entries :
    refined_raft_net_invariant_append_entries one_leaderLog_per_term.
  Proof using.
    unchanged update_elections_data_appendEntries_leaderLogs.
  Qed.

  Lemma one_leaderLog_per_term_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply one_leaderLog_per_term.
  Proof using.
    start_unchanged. auto.
  Qed.

  Lemma one_leaderLog_per_term_request_vote :
    refined_raft_net_invariant_request_vote one_leaderLog_per_term.
  Proof using.
    unchanged leaderLogs_update_elections_data_requestVote.
  Qed.

  Lemma update_elections_data_requestVoteReply_leaderLogs' :
    forall h h' t st t' ll' r,
      In (t', ll') (leaderLogs (update_elections_data_requestVoteReply h h' t r st)) ->
      In (t', ll') (leaderLogs (fst st))
      \/ (r = true
          /\ t = currentTerm (snd st)
          /\ ll' = log (snd st)
          /\ t' = currentTerm (snd st)
          /\ type (snd st) = Candidate
          /\ wonElection (dedup name_eq_dec (h' :: votesReceived (snd st))) = true).
  Proof using.
    unfold update_elections_data_requestVoteReply.
    intros.
    repeat break_match; auto.
    simpl in *. intuition.
    find_inversion. right.
    unfold handleRequestVoteReply in *.
    repeat break_match; simpl in *; intuition; try congruence;
    break_if; try congruence; do_bool; eauto using le_antisym.
  Qed.

  Lemma wonElection_length :
    forall votes,
      wonElection votes = true ->
      length votes > div2 (length nodes).
  Proof using.
    unfold wonElection. intros. find_apply_lem_hyp leb_true_le. omega.
  Qed.

  Lemma pigeon_nodes :
    forall (q1 q2 : list name),
      NoDup q1 ->
      NoDup q2 ->
      length q1 > div2 (length nodes) ->
      length q2 > div2 (length nodes) ->
      exists v, In v q1 /\ In v q2.
  Proof using one_node_params.
    intros. eapply pigeon with (l := nodes).
    - apply name_eq_dec.
    - intros. apply (@all_names_nodes _ multi_params).
    - intros. apply (@all_names_nodes _ multi_params).
    - apply (@no_dup_nodes _ multi_params).
    - assumption.
    - assumption.
    - apply div2_correct; assumption.
  Qed.

  (* two different hosts cannot both have the same term in their leader logs *)
  Lemma contradiction_case :
    forall (net : network ) t ll ll' (h h' : name) (p : packet (params := refined_multi_params (multi_params := multi_params))) t0 v xs ys,
      refined_raft_intermediate_reachable net ->
      pBody p = RequestVoteReply (raft_params := raft_params) t0 v ->
      nwPackets net = xs ++ p :: ys ->
      In (t, ll) (leaderLogs (fst (nwState net h))) ->
      In (t, ll') (leaderLogs (update_elections_data_requestVoteReply (pDst p) (pSrc p) t0 v (nwState net (pDst p)))) ->
      pDst p = h' ->
      pDst p <> h ->
      False.
  Proof using vvci cci vci llvwli.
    intros. unfold not in *. find_false.
    simpl in *. find_apply_lem_hyp update_elections_data_requestVoteReply_leaderLogs'.
    intro_refined_invariant leaderLogs_votesWithLog_invariant.
    break_or_hyp; repeat (apply_prop_hyp leaderLogs_votesWithLog In; break_exists).
    - assert (exists h, In h x /\ In h x0) by (apply pigeon_nodes; intuition).
      break_exists; break_and.
      do 2 (find_apply_hyp_hyp; break_exists; break_and).
      intro_refined_invariant votes_votesWithLog_correspond_invariant.
      do 2 (apply_prop_hyp votes_votesWithLog In).
      intro_refined_invariant votes_correct_invariant.
      eauto.
    - assert (exists h, In h x /\ In h (dedup name_eq_dec (pSrc p :: votesReceived (snd (nwState net (pDst p)))))).
      { eapply pigeon_nodes.
        - intuition.
        - apply NoDup_dedup.
        - intuition.
        - apply wonElection_length; intuition. }
      break_exists. break_and.
      find_apply_hyp_hyp; break_exists; break_and.
      intro_refined_invariant votes_votesWithLog_correspond_invariant.
      apply_prop_hyp votes_votesWithLog In.
      find_apply_lem_hyp in_dedup_was_in.
      simpl in *.
      intro_refined_invariant cronies_correct_invariant.
      intro_refined_invariant votes_correct_invariant.
      break_or_hyp; eauto.
  Qed.

  Lemma one_leaderLog_per_term_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply one_leaderLog_per_term.
  Proof using lltsi vvci cci vci llvwli.
    start. repeat find_higher_order_rewrite. repeat (update_destruct; rewrite_update).
    - split; [subst; auto|].
      find_copy_eapply_lem_hyp leaderLogs_update_elections_data_RVR; [|eauto].
      pose proof H.
      eapply leaderLogs_update_elections_data_RVR with (ll0 := ll) in H; [|eauto].
      intro_refined_invariant leaderLogs_currentTerm_sanity_candidate_invariant.
      intuition.
      + match goal with
        | [ h: _ |- _ ] => solve[eapply h; eauto]
        end.
      + apply_prop_hyp leaderLogs_currentTerm_sanity_candidate nwState; auto.
        find_copy_apply_lem_hyp handleRequestVoteReply_type. intuition; unfold raft_data in *; simpl in *.
        * subst. repeat find_rewrite. discriminate.
        * find_apply_lem_hyp lt_asym. congruence.
        * subst. repeat find_rewrite. find_apply_lem_hyp lt_irrefl. contradiction.
      + apply_prop_hyp leaderLogs_currentTerm_sanity_candidate nwState; auto.
        find_copy_apply_lem_hyp handleRequestVoteReply_type. intuition; unfold raft_data in *; simpl in *.
        * subst. repeat find_rewrite. discriminate.
        * find_apply_lem_hyp lt_asym. congruence.
        * subst. repeat find_rewrite. find_apply_lem_hyp lt_irrefl. contradiction.
      + subst. auto.
    - exfalso. eapply contradiction_case; eauto.
    - exfalso. eapply contradiction_case; eauto.
    - eauto.
  Qed.

  Lemma one_leaderLog_per_term_do_leader :
    refined_raft_net_invariant_do_leader one_leaderLog_per_term.
  Proof using.
    start_unchanged. find_rewrite. auto.
  Qed.

  Lemma one_leaderLog_per_term_do_generic_server :
    refined_raft_net_invariant_do_generic_server one_leaderLog_per_term.
  Proof using.
    start_unchanged. find_rewrite. auto.
  Qed.

  Lemma one_leaderLog_per_term_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset one_leaderLog_per_term.
  Proof using.
    start. repeat find_reverse_higher_order_rewrite. eauto.
  Qed.

  Lemma one_leaderLog_per_term_reboot :
    refined_raft_net_invariant_reboot one_leaderLog_per_term.
  Proof using.
    start_update; eapply H0; unfold reboot in *; try find_rewrite; simpl in *; eauto.
  Qed.

  Lemma one_leaderLog_per_term_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      one_leaderLog_per_term net.
  Proof using lltsi vvci cci vci llvwli rri.
    intros.
    apply refined_raft_net_invariant; auto.
    - apply one_leaderLog_per_term_init.
    - apply one_leaderLog_per_term_client_request.
    - apply one_leaderLog_per_term_timeout.
    - apply one_leaderLog_per_term_append_entries.
    - apply one_leaderLog_per_term_append_entries_reply.
    - apply one_leaderLog_per_term_request_vote.
    - apply one_leaderLog_per_term_request_vote_reply.
    - apply one_leaderLog_per_term_do_leader.
    - apply one_leaderLog_per_term_do_generic_server.
    - apply one_leaderLog_per_term_state_same_packet_subset.
    - apply one_leaderLog_per_term_reboot.
  Qed.

  Instance ollpti : one_leaderLog_per_term_interface.
  Proof.
    split; intros; intro_refined_invariant one_leaderLog_per_term_invariant;
      red; eapply_prop one_leaderLog_per_term.
  Qed.

End OneLeaderLogPerTerm.


From iris.algebra Require Import auth agree excl gmap frac.
From iris.proofmode Require Import proofmode.
From iris.base_logic Require Import invariants.
From iris.program_logic Require Import adequacy.
Require Import Eqdep_dec.
From cap_machine Require Import
     stdpp_extra iris_extra
     rules logrel fundamental.
From cap_machine.examples Require Import
     macros malloc counter_preamble disjoint_regions_tactics mkregion_helpers.

Instance DisjointList_list_Addr : DisjointList (list Addr).
Proof. exact (@disjoint_list_default _ _ app []). Defined.

Class memory_layout `{MachineParameters} := {
  (* awkward example: preamble & body *)
  counter_region_start : Addr;
  counter_preamble_start : Addr;
  counter_body_start : Addr;
  counter_region_end : Addr;

  (* pointer to the linking table, at the beginning of the region *)
  counter_linking_ptr_size :
    (counter_region_start + 1)%a = Some counter_preamble_start;

  (* preamble code, that allocates the closure *)
  counter_preamble_size :
    (counter_preamble_start + counter_preamble_instrs_length)%a
    = Some counter_body_start;

  (* code of the body, wrapped in the closure allocated by the preamble *)
  counter_body_size :
    (counter_body_start + counter_instrs_length)%a
    = Some counter_region_end;

  (* adversary code *)
  adv_start : Addr;
  adv_end : Addr;

  (* malloc routine *)
  malloc_start : Addr;
  malloc_memptr : Addr;
  malloc_mem_start : Addr;
  malloc_end : Addr;

  malloc_code_size :
    (malloc_start + length malloc_subroutine_instrs)%a
    = Some malloc_memptr;

  malloc_memptr_size :
    (malloc_memptr + 1)%a = Some malloc_mem_start;

  malloc_mem_size :
    (malloc_mem_start <= malloc_end)%a;

  (* fail routine *)
  assert_start : Addr;
  assert_cap : Addr;
  assert_flag : Addr;
  assert_end : Addr;

  assert_code_size :
    (assert_start + length assert_subroutine_instrs)%a = Some assert_cap;
  assert_cap_size :
    (assert_cap + 1)%a = Some assert_flag;
  assert_flag_size :
    (assert_flag + 1)%a = Some assert_end;

  (* link table *)
  link_table_start : Addr;
  link_table_end : Addr;

  link_table_size :
    (link_table_start + 2)%a = Some link_table_end;

  (* disjointness of all the regions above *)
  regions_disjoint :
    ## [
        finz.seq_between link_table_start link_table_end;
        [assert_flag];
        [assert_cap];
        finz.seq_between assert_start assert_cap;
        finz.seq_between malloc_mem_start malloc_end;
        [malloc_memptr];
        finz.seq_between malloc_start malloc_memptr;
        finz.seq_between adv_start adv_end;
        finz.seq_between counter_body_start counter_region_end;
        finz.seq_between counter_preamble_start counter_body_start;
        [counter_region_start]
       ];
}.

Definition offset_to_awkward `{memory_layout} : Z :=
  (* in this setup, the body of the counter comes just after the code
     of the preamble *)
  (counter_preamble_instrs_length - counter_preamble_move_offset)%Z.

Definition mk_initial_memory `{memory_layout} (adv_val: list Word) : gmap Addr Word :=
  (* pointer to the linking table *)
    list_to_map [(counter_region_start,
                  WCap RO link_table_start link_table_end link_table_start)]
  ∪ mkregion counter_preamble_start counter_body_start
       (* preamble: code that creates the awkward example closure *)
      (counter_preamble_instrs 0%Z (* offset to malloc in linking table *)
         offset_to_awkward (* offset to the body of the example *))
  ∪ mkregion counter_body_start counter_region_end
       (* body of the counter, that will be encapsulated in the closure
          created by the preamble *)
      (counter_instrs 1) (* offset to fail in the linking table *)

  ∪ mkregion adv_start adv_end
      (* adversarial code: any code or data, but no capabilities (see condition below) except for malloc *)
      (adv_val ++ [WCap E malloc_start malloc_end malloc_start])
  ∪ mkregion malloc_start malloc_memptr
      (* code for the malloc subroutine *)
      malloc_subroutine_instrs
  ∪ list_to_map
      (* Capability to malloc's memory pool, used by the malloc subroutine *)
      [(malloc_memptr, WCap RWX malloc_memptr malloc_end malloc_mem_start)]
  ∪ mkregion malloc_mem_start malloc_end
      (* Malloc's memory pool, initialized to zero *)
      (region_addrs_zeroes malloc_mem_start malloc_end)
  ∪ mkregion assert_start assert_cap
      (* code for the failure subroutine *)
      assert_subroutine_instrs
  ∪ list_to_map [(assert_cap, WCap RW assert_flag assert_end assert_flag)]
      (* pointer to the "assert" flag, set to 1 by the routine *)
  ∪ list_to_map [(assert_flag, WInt 0%Z)]
      (* assert flag, initialized to 0 *)
  ∪ mkregion link_table_start link_table_end
      (* link table, with pointers to the malloc and failure subroutines *)
      [WCap E malloc_start malloc_end malloc_start;
       WCap E assert_start assert_end assert_start]
.

Definition is_initial_memory `{memory_layout} (m: gmap Addr Word) :=
  ∃ (adv_val: list Word),
  m = mk_initial_memory adv_val
  ∧
  (* the adversarial region in memory must only contain instructions, no
     capabilities (it can thus only access capabilities the awkward preamble
     passes it through the registers) *)
  Forall (λ w, is_z w = true) adv_val
  ∧
  (adv_start + (length adv_val + 1)%nat)%a = Some adv_end.

Definition is_initial_registers `{memory_layout} (reg: gmap RegName Word) :=
  reg !! PC = Some (WCap RX counter_region_start counter_region_end counter_preamble_start) ∧
  reg !! r_t0 = Some (WCap RWX adv_start adv_end adv_start) ∧
  (∀ (r: RegName), r ∉ ({[ PC; r_t0 ]} : gset RegName) →
    ∃ (w:Word), reg !! r = Some w ∧ is_z w = true).

Lemma initial_registers_full_map `{MachineParameters, memory_layout} reg :
  is_initial_registers reg →
  (∀ r, is_Some (reg !! r)).
Proof.
  intros (HPC & Hr0 & Hothers) r.
  destruct (decide (r = PC)) as [->|]. by eauto.
  destruct (decide (r = r_t0)) as [->|]. by eauto.
  destruct (Hothers r) as (w & ? & ?); [| eauto]. set_solver.
Qed.

Section Adequacy.
  Context (Σ: gFunctors).
  Context {inv_preg: invGpreS Σ}.
  Context {mem_preg: gen_heapGpreS Addr Word Σ}.
  Context {reg_preg: gen_heapGpreS RegName Word Σ}.
  Context {seal_store_preg: sealStorePreG Σ}.
  Context {na_invg: na_invG Σ}.
  Context `{MP: MachineParameters}.

  Definition assertN : namespace := nroot .@ "lib" .@ "assert".
  Definition flagN : namespace := nroot .@ "lib" .@ "assert_flag".
  Definition mallocN : namespace := nroot .@ "lib" .@ "malloc".

  Lemma counter_adequacy' `{memory_layout} (m m': Mem) (reg reg': Reg) (es: list cap_lang.expr):
    is_initial_memory m →
    is_initial_registers reg →
    rtc erased_step ([Seq (Instr Executable)], (reg, m)) (es, (reg', m')) →
    m' !! assert_flag = Some (WInt 0%Z).
  Proof.
    intros Hm Hreg Hstep.
    pose proof (@wp_invariance Σ cap_lang _ NotStuck) as WPI. cbn in WPI.
    pose (fun (c: ExecConf) => c.2 !! assert_flag = Some (WInt 0%Z)) as state_is_good.
    specialize (WPI (Seq (Instr Executable)) (reg, m) es (reg', m') (state_is_good (reg', m'))).
    eapply WPI. 2: assumption. intros Hinv κs. clear WPI.

    destruct Hm as (adv_val & Hm & Hadv_val & adv_size).
    iMod (gen_heap_init (m:Mem)) as (mem_heapg) "(Hmem_ctx & Hmem & _)".
    iMod (gen_heap_init (reg:Reg)) as (reg_heapg) "(Hreg_ctx & Hreg & _)".
    iMod (seal_store_init) as (seal_storeg) "Hseal_store".
    iMod (@na_alloc Σ na_invg) as (logrel_nais) "Hna".

    pose memg := MemG Σ Hinv mem_heapg.
    pose regg := RegG Σ Hinv reg_heapg.
    pose logrel_na_invs := Build_logrel_na_invs _ na_invg logrel_nais.

    pose proof (
      @counter_preamble_spec Σ memg regg seal_storeg logrel_na_invs
    ) as Spec.

    (* Extract points-to for the various regions in memory *)

    pose proof regions_disjoint as Hdisjoint.
    rewrite {2}Hm.
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_link_table & Hdisjoint).
    (* iDestruct (big_sepM_union with "Hmem") as "[Hmem Hfail_flag]". *)
    (* { disjoint_map_to_list. set_solver +Hdisj_fail_flag. } *)
    (* iDestruct (big_sepM_insert with "Hfail_flag") as "[Hfail_flag _]". *)
    (*   by apply lookup_empty. cbn [fst snd]. *)
    (* rewrite disjoint_list_cons in Hdisjoint |- *. intros (Hdisj_link_table & Hdisjoint). *)
    iDestruct (big_sepM_union with "Hmem") as "[Hmem Hlink_table]".
    { disjoint_map_to_list. set_solver+ Hdisj_link_table. }
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_assert_flag & Hdisjoint).
    iDestruct (big_sepM_union with "Hmem") as "[Hmem Hassert_flag]".
    { disjoint_map_to_list. set_solver +Hdisj_assert_flag. }
    iDestruct (big_sepM_insert with "Hassert_flag") as "[Hassert_flag _]".
      by apply lookup_empty. cbn [fst snd].
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_assert_cap & Hdisjoint).
    iDestruct (big_sepM_union with "Hmem") as "[Hmem Hassert_cap]".
    { disjoint_map_to_list. set_solver +Hdisj_assert_cap. }
    iDestruct (big_sepM_insert with "Hassert_cap") as "[Hassert_cap _]".
      by apply lookup_empty. cbn [fst snd].
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_assert & Hdisjoint).
    iDestruct (big_sepM_union with "Hmem") as "[Hmem Hassert]".
    { disjoint_map_to_list. set_solver +Hdisj_assert. }
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_malloc_mem & Hdisjoint).
    iDestruct (big_sepM_union with "Hmem") as "[Hmem Hmalloc_mem]".
    { disjoint_map_to_list. set_solver +Hdisj_malloc_mem. }
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_malloc_memptr & Hdisjoint).
    iDestruct (big_sepM_union with "Hmem") as "[Hmem Hmalloc_memptr]".
    { disjoint_map_to_list. set_solver +Hdisj_malloc_memptr. }
    iDestruct (big_sepM_insert with "Hmalloc_memptr") as "[Hmalloc_memptr _]".
      by apply lookup_empty. cbn [fst snd].
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_malloc_code & Hdisjoint).
    iDestruct (big_sepM_union with "Hmem") as "[Hmem Hmalloc_code]".
    { disjoint_map_to_list. set_solver +Hdisj_malloc_code. }
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_adv & Hdisjoint).
    iDestruct (big_sepM_union with "Hmem") as "[Hmem Hadv]".
    { disjoint_map_to_list. set_solver +Hdisj_adv. }
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_counter_body & Hdisjoint).
    iDestruct (big_sepM_union with "Hmem") as "[Hmem Hcounter_body]".
    { disjoint_map_to_list. set_solver +Hdisj_counter_body. }
    rewrite disjoint_list_cons in Hdisjoint |- *. destruct Hdisjoint as (Hdisj_counter_preamble & _).
    iDestruct (big_sepM_union with "Hmem") as "[Hcounter_link Hcounter_preamble]".
    { disjoint_map_to_list. set_solver +Hdisj_counter_preamble. }
    iDestruct (big_sepM_insert with "Hcounter_link") as "[Hcounter_link _]". by apply lookup_empty.
    cbn [fst snd].
    clear Hdisj_link_table Hdisj_assert_flag Hdisj_assert_cap Hdisj_assert Hdisj_malloc_mem
          Hdisj_malloc_memptr Hdisj_malloc_code Hdisj_adv Hdisj_counter_body Hdisj_counter_preamble.

    (* Massage points-to into sepL2s with permission-pointsto *)

    iDestruct (mkregion_prepare with "[$Hlink_table]") as ">Hlink_table". by apply link_table_size.
    iDestruct (mkregion_prepare with "[$Hassert]") as ">Hassert". by apply assert_code_size.
    iDestruct (mkregion_prepare with "[$Hmalloc_mem]") as ">Hmalloc_mem".
    { rewrite replicate_length /finz.dist. clear.
      generalize malloc_mem_start malloc_end malloc_mem_size. solve_addr. }
    iDestruct (mkregion_prepare with "[$Hmalloc_code]") as ">Hmalloc_code".
      by apply malloc_code_size.
    iDestruct (mkregion_prepare with "[$Hadv]") as ">Hadv". rewrite app_length /=. by apply adv_size.
    iDestruct (mkregion_prepare with "[$Hcounter_preamble]") as ">Hcounter_preamble".
      by apply counter_preamble_size.
    iDestruct (mkregion_prepare with "[$Hcounter_body]") as ">Hcounter_body". by apply counter_body_size.
    rewrite -/(counter _ _) -/(counter_preamble _ _).

    (* Split the link table *)

    rewrite (finz_seq_between_cons link_table_start link_table_end).
    2: { generalize link_table_size; clear; solve_addr. }
    set link_entry_fail := (link_table_start ^+ 1)%a.
    rewrite (finz_seq_between_cons link_entry_fail link_table_end).
    2: { generalize link_table_size; clear. subst link_entry_fail.
         generalize link_table_start link_table_end. solve_addr. }
    rewrite (_: (link_entry_fail ^+ 1)%a = link_table_end).
    2: { generalize link_table_size; clear. subst link_entry_fail.
         generalize link_table_start link_table_end. solve_addr. }
    iDestruct (big_sepL2_cons with "Hlink_table") as "[Hlink1 Hlink_table]".
    iDestruct (big_sepL2_cons with "Hlink_table") as "[Hlink2 _]".

    (* Allocate relevant invariants *)

    iMod (inv_alloc flagN ⊤ (assert_flag ↦ₐ WInt 0%Z) with "Hassert_flag")%I as "#Hinv_assert_flag".
    iMod (na_inv_alloc logrel_nais ⊤ assertN (assert_inv assert_start assert_flag assert_end)
            with "[Hassert Hassert_cap]") as "#Hinv_assert".
    { iNext. rewrite /assert_inv. iExists assert_cap. iFrame. rewrite /proofmode.codefrag.
      rewrite (_: (assert_start ^+ length assert_subroutine_instrs)%a = assert_cap).
       2: { generalize assert_code_size. solve_addr. } iFrame.
       iPureIntro. generalize assert_code_size, assert_cap_size, assert_flag_size. cbn. done. }
    iMod (na_inv_alloc logrel_nais ⊤ mallocN (malloc_inv malloc_start malloc_end)
            with "[Hmalloc_code Hmalloc_memptr Hmalloc_mem]") as "#Hinv_malloc".
    { iNext. rewrite /malloc_inv. iExists malloc_memptr, malloc_mem_start.
      iFrame. rewrite /proofmode.codefrag.
      rewrite (_: (malloc_start ^+ length malloc_subroutine_instrs)%a = malloc_memptr).
      2: { generalize malloc_code_size. solve_addr. } iFrame.
      iPureIntro. generalize malloc_code_size malloc_mem_size malloc_memptr_size. cbn.
      clear; unfold malloc_subroutine_instrs_length; intros; repeat split; solve_addr. }
    iDestruct (simple_malloc_subroutine_valid with "[$Hinv_malloc]") as "Hmalloc_val".

    (* Show validity of the adversary capability *)
    assert (contiguous_between (finz.seq_between adv_start adv_end) adv_start adv_end) as Hcont.
    { apply contiguous_between_region_addrs. clear -adv_size. solve_addr. }
    iDestruct (contiguous_between_program_split with "Hadv") as (adv_words malloc_word adv_end') "(Hadv & Hmalloc & #Hcont)";[eauto|].
    iDestruct "Hcont" as %(Hcontadv & Hcontmalloc & Heqapp & Hlink).
    iDestruct (big_sepL2_length with "Hmalloc") as %Hlen1. simpl in Hlen1.
    iDestruct (big_sepL2_length with "Hadv") as %Hlen2. simpl in Hlen2.

    iMod (region_inv_alloc _ (adv_words ++ malloc_word)
                           (adv_val ++ [WCap E malloc_start malloc_end malloc_start])
            with "[Hadv Hmalloc]") as "Hadv".
    { iApply (big_sepL2_app');[auto|].
      iSplitL "Hadv".
      - iApply (big_sepL2_mono with "Hadv").
        intros k v1 v2 Hv1 Hv2. cbn. iIntros. iFrame.
        pose proof (Forall_lookup_1 _ _ _ _ Hadv_val Hv2) as Hncap.
        destruct v2; [| by inversion Hncap..].
        rewrite fixpoint_interp1_eq /=. done.
      - destruct malloc_word;[inversion Hlen1|]. destruct malloc_word;[|inversion Hlen1].
        iDestruct "Hmalloc" as "[Hmalloc _]". iFrame "∗ #". done.
    }
    iDestruct "Hadv" as "#Hadv".

    (* Apply the spec, obtain that the PC is in the expression relation *)

    iAssert ((interp_expr interp reg) (WCap RX counter_region_start counter_region_end counter_preamble_start))
      with "[Hcounter_preamble Hcounter_body Hinv_malloc Hcounter_link Hlink1 Hlink2]" as "HE".
    { assert (isCorrectPC_range RX counter_region_start counter_region_end
                                counter_preamble_start counter_body_start).
      { intros a [Ha1 Ha2]. constructor; auto.
        generalize counter_linking_ptr_size counter_preamble_size counter_body_size. revert Ha1 Ha2. clear.
        unfold counter_instrs_length, counter_preamble_instrs_length. solve_addr. }
      set counter_preamble_move_addr := (counter_preamble_start ^+ counter_preamble_move_offset)%a.
      assert ((counter_preamble_start + counter_preamble_move_offset)%a = Some counter_preamble_move_addr).
      { clear. subst counter_preamble_move_addr.
        generalize counter_preamble_size.
        unfold counter_preamble_instrs_length, counter_preamble_move_offset.
        generalize counter_preamble_start counter_body_start. solve_addr. }
      assert (counter_preamble_move_addr + offset_to_awkward = Some counter_body_start)%a.
      { generalize counter_preamble_size.
        unfold counter_preamble_move_addr, offset_to_awkward, counter_preamble_instrs_length.
        unfold counter_preamble_move_offset. clear.
        generalize counter_preamble_start counter_body_start. solve_addr. }
      assert (isCorrectPC_range RX counter_region_start counter_region_end
                                counter_body_start counter_region_end).
      { intros a [Ha1 Ha2]. constructor; auto.
        generalize counter_linking_ptr_size counter_preamble_size counter_body_size. revert Ha1 Ha2; clear.
        unfold counter_instrs_length, counter_preamble_instrs_length. solve_addr. }

      iApply (Spec with "[$Hinv_malloc $Hinv_assert $Hcounter_body $Hcounter_preamble $Hcounter_link $Hlink1 $Hlink2]");
        try eassumption.
      - apply contiguous_between_region_addrs. generalize counter_preamble_size; clear.
        unfold counter_preamble_instrs_length. solve_addr.
      - apply le_addr_withinBounds. clear; solve_addr.
        generalize link_table_size; clear; solve_addr.
      - subst link_entry_fail. apply le_addr_withinBounds.
        generalize link_table_start; clear; solve_addr.
        generalize link_table_start link_table_end link_table_size. clear; solve_addr.
      - clear; generalize link_table_start; solve_addr.
      - clear; subst link_entry_fail;
        generalize link_table_start link_table_end link_table_size; solve_addr.
      - apply contiguous_between_region_addrs. generalize counter_body_size; clear.
        unfold counter_instrs_length. solve_addr.
      - solve_ndisj.
      - solve_ndisj. }

    clear Hm Spec. rewrite /interp_expr /=.

    (* prepare registers *)

    unfold is_initial_registers in Hreg.
    destruct Hreg as (HPC & Hstk & Hrothers).

    (* Specialize the expression relation, showing that registers are valid *)

    iSpecialize ("HE" with "[Hreg Hna]").
    { iFrame. iSplit; cycle 1.
      { iFrame. rewrite /registers_mapsto. by rewrite insert_id. }
      { iSplit. iPureIntro; intros; by apply initial_registers_full_map.
        (* All capabilities in registers are valid! *)
        iIntros (r v HrnPC Hsv).
        (* r0 (return pointer to the adversary) is valid. Prove it using the
           fundamental theorem. *)
        destruct (decide (r = r_t0)) as [ -> |].
        { rewrite Hsv in Hstk. inversion Hstk; subst v.
          rewrite !fixpoint_interp1_eq /=.
          iDestruct (big_sepL2_length with "Hadv") as %Hadvlength.
          iDestruct (big_sepL2_to_big_sepL_l with "Hadv") as "Hadv'";auto. rewrite -Heqapp.
          iApply (big_sepL_mono with "Hadv'"). iIntros (k v Hkv). cbn.
          iIntros "H". iExists (interp). iFrame.
          iSplit;auto.
        }

        (* Other registers *)
        destruct (Hrothers r) as [rw [Hrw Hncap] ]. set_solver.
        destruct rw; [| by inversion Hncap..]. simplify_map_eq.
        by rewrite !fixpoint_interp1_eq /=. } }

    (* We get a WP; conclude using the rest of the Iris adequacy theorem *)

    iModIntro.
    (* Same as the state_interp of [memG_irisG] in rules_base.v *)
    iExists (fun σ κs _ => ((gen_heap_interp σ.1) ∗ (gen_heap_interp σ.2)))%I.
    iExists (fun _ => True)%I. cbn. iFrame.
    iSplitL "HE". { iApply (wp_wand with "HE"). eauto. }
    iIntros "[Hreg' Hmem']". iExists (⊤ ∖ ↑flagN).
    iInv flagN as ">Hflag" "Hclose".
    iDestruct (gen_heap_valid with "Hmem' Hflag") as %Hm'_flag.
    iModIntro. iPureIntro. apply Hm'_flag.
    Unshelve.
  Qed.

End Adequacy.

Theorem counter_adequacy `{MachineParameters} `{memory_layout}
        (m m': Mem) (reg reg': Reg) (es: list cap_lang.expr):
  is_initial_memory m →
  is_initial_registers reg →
  rtc erased_step ([Seq (Instr Executable)], (reg, m)) (es, (reg', m')) →
  m' !! assert_flag = Some (WInt 0%Z).
Proof.
  set (Σ := #[invΣ; gen_heapΣ Addr Word; gen_heapΣ RegName Word; sealStorePreΣ;
              na_invΣ]).
  eapply (@counter_adequacy' Σ); typeclasses eauto.
Qed.


From Coq Require Import String Arith ZArith PropExtensionality.

From Vyper Require Import Config Calldag.
From Vyper.L10 Require Import Base.
From Vyper.L40 Require Import AST Descend Expr Callset Descend.
From Vyper.L40Metered Require Import Interpret.

(** The expression interpreter is in L40Metered.Interpret.
    This is the proof that both interpreters of L40 work the same on expressions.
 *)

Lemma expr_metering_ok {C: VyperConfig}
                       {bigger_call_depth_bound smaller_call_depth_bound: nat}
                       (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
                       {cd: calldag}
                       (fc: fun_ctx cd bigger_call_depth_bound)
                       (do_call: forall
                                     (fc': fun_ctx cd smaller_call_depth_bound)
                                     (world: world_state)
                                     (arg_values: list uint256),
                                   world_state * expr_result uint256)
                       (do_call_metered: forall
                                           (decl: L40.AST.decl)
                                           (world: world_state)
                                           (arg_values: list uint256),
                                         world_state * option (expr_result uint256))
                       (DoCallOk: forall (fc': fun_ctx cd smaller_call_depth_bound)
                                         (world: world_state)
                                         (arg_values: list uint256),
                                    let '(world', result) := do_call fc' world arg_values in
                                      do_call_metered (fun_decl fc') world arg_values
                                       =
                                      (world', Some result))
                       (builtins: string -> option builtin)
                       (world: world_state)
                       (loc: memory)
                       (loops: list loop_ctx)
                       (e: expr)
                       (CallOk: let _ := string_set_impl in
                                  FSet.is_subset (expr_callset e)
                                                 (decl_callset (fun_decl fc))
                                  = true):
  let '(world', result) := interpret_expr Ebound fc do_call builtins world loc loops e CallOk in
    interpret_expr_metered (cd_decls cd) do_call_metered builtins world loc loops e
     =
    (world', Some result).
Proof.
revert world loc loops. induction e using expr_ind'; try easy; intros; cbn.
{ (* PrivateCall *)
  unfold fun_ctx_descend.
  unfold cd_declmap.
  unfold map_lookup.
  refine (match Map.lookup (cd_decls cd) name as z return _ = z -> _ with
          | Some d => fun E => _
          | None => fun NotFound => _
          end eq_refl).
  2:{
    remember (fun d (Edecl : Map.lookup (cd_decls cd) name = Some d) =>
               Descend.fun_ctx_descend_inner fc CallOk Ebound eq_refl Edecl) as branch_not_taken.
    clear Heqbranch_not_taken.
    revert branch_not_taken.
    now rewrite NotFound.
  }
  replace (match
             Map.lookup (cd_decls cd) name as maybe_decl
             return (Map.lookup (cd_decls cd) name = maybe_decl -> option (fun_ctx cd smaller_call_depth_bound))
           with
           | Some d0 =>
               fun Edecl : Map.lookup (cd_decls cd) name = Some d0 =>
               Descend.fun_ctx_descend_inner fc CallOk Ebound eq_refl Edecl
           | None => fun _ : Map.lookup (cd_decls cd) name = None => None
           end eq_refl) with (Descend.fun_ctx_descend_inner fc CallOk Ebound eq_refl E).
  2:{
    remember (@Descend.fun_ctx_descend_inner C bigger_call_depth_bound smaller_call_depth_bound cd
               (@PrivateCall C name args) fc CallOk Ebound name args
               (@eq_refl (@expr C) (@PrivateCall C name args))) as foo.
    clear Heqfoo.
    unfold cd_declmap in foo.
    destruct (Map.lookup (cd_decls cd) name). 2:discriminate.
    inversion E; subst.
    f_equal.
    apply proof_irrelevance.
  }
  unfold Descend.fun_ctx_descend_inner.
  assert (DepthmapOk := cd_depthmap_ok cd name).
  rewrite E in DepthmapOk.
  refine (match cd_depthmap cd name as z return _ = z -> _ with
          | Some depth => fun Edepth => _
          | None => fun NotFound => _
          end eq_refl).
  2: now rewrite NotFound in DepthmapOk.
  rewrite Edepth in DepthmapOk.
  rewrite FSet.for_all_ok in DepthmapOk.
  replace (match
             cd_depthmap cd name as maybe_depth
             return (cd_depthmap cd name = maybe_depth -> option (fun_ctx cd smaller_call_depth_bound))
           with
           | Some depth0 =>
               fun Edepth0 : cd_depthmap cd name = Some depth0 =>
               Some
                 {|
                   fun_name := name;
                   fun_depth := depth0;
                   fun_depth_ok := Edepth0;
                   fun_decl := d;
                   fun_decl_ok := E;
                   fun_bound_ok := Descend.call_descend' fc CallOk Ebound eq_refl E Edepth0
                 |}
           | None => _
           end eq_refl)
  with (Some
           {|
             fun_name := name;
             fun_depth := depth;
             fun_depth_ok := Edepth;
             fun_decl := d;
             fun_decl_ok := E;
             fun_bound_ok := Descend.call_descend' fc CallOk Ebound eq_refl E Edepth
           |}).
  2:{
    remember (fun Edepth0 : cd_depthmap cd name = None =>
                False_rect (option (fun_ctx cd smaller_call_depth_bound)) (Descend.fun_ctx_descend_helper E Edepth0))
      as bad. clear Heqbad.
    remember (fun depth0 (Edepth0 : cd_depthmap cd name = Some depth0) =>
    Some
      {|
        fun_name := name;
        fun_depth := depth0;
        fun_depth_ok := Edepth0;
        fun_decl := d;
        fun_decl_ok := E;
        fun_bound_ok := Descend.call_descend' fc CallOk Ebound eq_refl E Edepth0
      |}) as f.
    replace (Some
              {|
                fun_name := name;
                fun_depth := depth;
                fun_depth_ok := Edepth;
                fun_decl := d;
                fun_decl_ok := E;
                fun_bound_ok := Descend.call_descend' fc CallOk Ebound eq_refl E Edepth
              |})
    with (f depth Edepth)
    by now subst.
    clear Heqf.
    destruct (cd_depthmap cd name). 2:discriminate.
    inversion Edepth. subst.
    f_equal.
    apply proof_irrelevance.
  }

  remember (fix interpret_expr_list
      (world0 : world_state) (loc0 : memory) (e : list expr)
      (CallOk0 : FSet.is_subset (expr_list_callset e) (decl_callset (fun_decl fc)) = true) {struct e} :
        world_state * expr_result (list uint256) := _) as interpret_expr_list.
  remember (fix interpret_expr_list (world0 : world_state) (loc0 : memory) (e : list expr) {struct e} :
            world_state * option (expr_result (list uint256)) := _) as interpret_expr_list_metered.

  assert (ArgsOk: forall w l COk,
                  let '(w', result) := interpret_expr_list w l args COk
                  in interpret_expr_list_metered w l args = (w', Some result)).
  {
    induction args. { now subst. }
    rewrite Heqinterpret_expr_list. rewrite Heqinterpret_expr_list_metered.
    cbn.
    rewrite<- Heqinterpret_expr_list. rewrite<- Heqinterpret_expr_list_metered.
    clear Heqinterpret_expr_list Heqinterpret_expr_list_metered.
    intros.
    assert (CallOk': let _ := string_set_impl in
                     FSet.is_subset (expr_callset (PrivateCall name args))
                                    (decl_callset (fun_decl fc))
                      = true).
    {
      cbn. cbn in CallOk.
      rewrite FSet.add_subset_and.
      rewrite FSet.add_subset_and in CallOk.
      rewrite Bool.andb_true_iff.
      rewrite Bool.andb_true_iff in CallOk.
      destruct CallOk as (CallOk, HasFun).
      split. 2:assumption. clear HasFun.
      rewrite FSet.union_subset_and in CallOk.
      rewrite Bool.andb_true_iff in CallOk.
      tauto.
    }
    assert (IH := IHargs CallOk' (List.Forall_inv_tail H) w l (callset_descend_tail eq_refl COk)).
    clear IHargs.
    destruct (interpret_expr_list w l args (callset_descend_tail eq_refl COk)) as (world', result).
    rewrite IH. clear IH.
    destruct result. 2:trivial.
    assert (HeadOk := List.Forall_inv H (callset_descend_head eq_refl COk) world' l loops).
    cbn in HeadOk. clear H.
    destruct (interpret_expr Ebound fc do_call builtins world' l loops a (callset_descend_head eq_refl COk))
      as (ww, ll).
    rewrite HeadOk.
    now destruct ll.
  }

  assert (DoCallMeteredFinishes:
            forall (fc' : fun_ctx cd smaller_call_depth_bound) (w: world_state)
                   (arg_values : list uint256),
              snd (do_call_metered (fun_decl fc') w arg_values) <> None).
  {
    intros.
    assert (D := DoCallOk fc' w arg_values).
    destruct (do_call fc' w arg_values).
    intro HH.
    rewrite D in HH.
    inversion HH.
  }
  assert (DFinishes: forall (w: world_state)
                            (arg_values : list uint256),
            snd (do_call_metered d w arg_values) <> None).
  {
    apply (DoCallMeteredFinishes {|
                   fun_name := name;
                   fun_depth := depth;
                   fun_depth_ok := Edepth;
                   fun_decl := d;
                   fun_decl_ok := E;
                   fun_bound_ok := Descend.call_descend' fc CallOk Ebound eq_refl E Edepth
                 |}).
  }
  assert (DoCallRewrite: forall (w: world_state)
                                (arg_values : list uint256),
           do_call {|
                   fun_name := name;
                   fun_depth := depth;
                   fun_depth_ok := Edepth;
                   fun_decl := d;
                   fun_decl_ok := E;
                   fun_bound_ok := Descend.call_descend' fc CallOk Ebound eq_refl E Edepth
                 |} w arg_values
            =
           match snd (do_call_metered d w arg_values) as z return _ = z -> _ with
           | Some result => fun _ => (fst (do_call_metered d w arg_values), result)
           | None => fun Bad => False_rect _ (DFinishes _ _ Bad)
           end eq_refl).
  {
    intros.
    remember {|
                   fun_name := name;
                   fun_depth := depth;
                   fun_depth_ok := Edepth;
                   fun_decl := d;
                   fun_decl_ok := E;
                   fun_bound_ok := Descend.call_descend' fc CallOk Ebound eq_refl E Edepth
             |} as fc'.
    assert (D := DoCallOk fc' w arg_values).
    destruct (do_call fc' w arg_values) as (w', r').
    remember (fun Bad : snd (do_call_metered d w arg_values) = None =>
                False_rect (world_state * expr_result uint256) (DFinishes w arg_values Bad))
      as foo. clear Heqfoo.
    remember (snd (do_call_metered d w arg_values)) as s.
    destruct s.
    {
      subst fc'. cbn in D.
      rewrite D in *.
      cbn in *.
      f_equal.
      now inversion Heqs.
    }
    subst fc'. cbn in D.
    rewrite D in *.
    cbn in Heqs.
    discriminate.
  }
  clear H Heqinterpret_expr_list Heqinterpret_expr_list_metered.
  assert (A := ArgsOk world loc (callset_descend_args eq_refl CallOk)). clear ArgsOk.
  destruct (interpret_expr_list world loc args (callset_descend_args eq_refl CallOk))
    as (world', result_args).
  rewrite A.
  unfold cd_declmap in *.
  destruct result_args. 2:{ now rewrite E. }
  rewrite DoCallRewrite. clear DoCallRewrite.
  rewrite E.
  assert (Ok := DFinishes world' value).
  remember (fun Bad : snd (do_call_metered d world' value) = None =>
             False_rect (world_state * expr_result uint256) (DFinishes world' value Bad))
    as bad. clear Heqbad.
  remember (snd (do_call_metered d world' value)) as x. destruct x.
  { rewrite Heqx. now destruct (do_call_metered d world' value). }
  symmetry in Heqx. contradiction.
}
(* BuiltinCall *)
remember (fix interpret_expr_list
    (world0 : world_state) (loc0 : memory) (e : list expr)
    (CallOk0 : FSet.is_subset (expr_list_callset e) (decl_callset (fun_decl fc)) = true) {struct e} :
      world_state * expr_result (list uint256) := _) as interpret_expr_list.
remember (fix interpret_expr_list (world0 : world_state) (loc0 : memory) (e : list expr) {struct e} :
          world_state * option (expr_result (list uint256)) := _) as interpret_expr_list_metered.
assert (ArgsOk: forall w l COk,
                let '(w', result) := interpret_expr_list w l args COk
                in interpret_expr_list_metered w l args = (w', Some result)).
{
  induction args. { now subst. }
  rewrite Heqinterpret_expr_list. rewrite Heqinterpret_expr_list_metered.
  cbn.
  rewrite<- Heqinterpret_expr_list. rewrite<- Heqinterpret_expr_list_metered.
  clear Heqinterpret_expr_list Heqinterpret_expr_list_metered.
  intros.
  assert (CallOk': let _ := string_set_impl in
                   FSet.is_subset (expr_callset (BuiltinCall name args))
                                  (decl_callset (fun_decl fc))
                    = true).
  {
    cbn. cbn in CallOk.
    rewrite FSet.union_subset_and in CallOk.
    rewrite Bool.andb_true_iff in CallOk.
    tauto.
  }
  assert (IH := IHargs CallOk' (List.Forall_inv_tail H) w l (callset_descend_tail eq_refl COk)).
  clear IHargs.
  destruct (interpret_expr_list w l args (callset_descend_tail eq_refl COk)) as (world', result).
  rewrite IH. clear IH.
  destruct result. 2:trivial.
  assert (HeadOk := List.Forall_inv H (callset_descend_head eq_refl COk) world' l loops).
  cbn in HeadOk. clear H.
  destruct (interpret_expr Ebound fc do_call builtins world' l loops a (callset_descend_head eq_refl COk))
    as (ww, ll).
  rewrite HeadOk.
  now destruct ll.
}
clear H Heqinterpret_expr_list Heqinterpret_expr_list_metered.
assert (A := ArgsOk world loc (callset_descend_builtin_args eq_refl CallOk)). clear ArgsOk.
destruct (interpret_expr_list world loc args (callset_descend_builtin_args eq_refl CallOk))
  as (world', result_args).
rewrite A. clear A.
destruct result_args. 2:reflexivity.
destruct (builtins name). 2:reflexivity.
destruct b as (arity, b).
remember (fun Earity : (arity =? Datatypes.length value) = true => call_builtin value Earity (b world'))
  as good_branch_1.
remember (fun Earity : (arity =? Datatypes.length value) = true =>
   let '(world'', result0) := call_builtin value Earity (b world') in (world'', Some result0))
  as good_branch_2.
enough (Q: forall E, let '(w, result) := good_branch_1 E in
           good_branch_2 E = (w, Some result)).
{
  clear Heqgood_branch_1 Heqgood_branch_2.
  destruct (arity =? Datatypes.length value).
  { apply Q. }
  trivial.
}
subst. intro E. now destruct (call_builtin value E (b world')) as (w, result).
Qed.


(** * Push-Button Synthesis of Saturated Reduction *)
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.MSets.MSetPositive.
Require Import Coq.Lists.List.
Require Import Coq.QArith.QArith_base Coq.QArith.Qround.
Require Import Coq.derive.Derive.
Require Import Crypto.Util.ErrorT.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ListUtil.FoldBool.
Require Import Crypto.Util.Strings.Decimal.
Require Import Crypto.Util.Strings.Show.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Zselect.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Tactics.HasBody.
Require Import Crypto.Util.Tactics.Head.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Rewriter.Language.Wf.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.Stringification.Language.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.Saturated.
Require Import Crypto.Arithmetic.SolinasReduction.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Require Import Crypto.PushButtonSynthesis.Primitives.
Require Import Crypto.PushButtonSynthesis.SaturatedSolinasReificationCache.
Require Import Crypto.PushButtonSynthesis.SolinasReductionReificationCache.
Require Import Crypto.Assembly.Equivalence.
Import ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope. Local Open Scope bool_scope.

Import
  Language.Wf.Compilers
  Language.Compilers
  AbstractInterpretation.Compilers
  Stringification.Language.Compilers.
Import Compilers.API.

Import COperationSpecifications.Primitives.
Import COperationSpecifications.Solinas.
Import COperationSpecifications.SolinasReduction.

Import Associational Positional.
Import SolinasReduction.

Local Coercion Z.of_nat : nat >-> Z.
Local Coercion QArith_base.inject_Z : Z >-> Q.
Local Coercion Z.pos : positive >-> Z.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Local Opaque reified_mul_gen. (* needed for making [autorewrite] not take a very long time *)
Local Opaque reified_square_gen.
(* needed for making [autorewrite] with [Set Keyed Unification] fast *)
Local Opaque expr.Interp.

Section __.
  Context {output_language_api : ToString.OutputLanguageAPI}
          {pipeline_opts : PipelineOptions}
          {pipeline_to_string_opts : PipelineToStringOptions}
          {synthesis_opts : SynthesisOptions}
          (s : Z)
          (c : list (Z * Z)).
  Context (machine_wordsize : machine_wordsize_opt).

  Local Instance override_pipeline_opts : PipelineOptions
    := {| widen_bytes := true (* true, because we don't allow byte-sized things anyway, so we should not expect carries to be widened to byte-size when emitting C code *)
       |}.

  (* We include [0], so that even after bounds relaxation, we can
       notice where the constant 0s are, and remove them. *)
  Definition possible_values_of_machine_wordsize
    := prefix_with_carry [machine_wordsize].

  Definition n : nat := Z.to_nat (Qceiling (Z.log2_up s / machine_wordsize)).
  Definition m := s - Associational.eval c.
  Definition weight := UniformWeight.uweight machine_wordsize.
  Definition up_bound := 2 ^ (machine_wordsize / 4).
  Definition base : Z := 2 ^ machine_wordsize.

  Local Notation possible_values := possible_values_of_machine_wordsize.
  Local Notation boundsn := (saturated_bounds n machine_wordsize).
  Local Notation bounds4 := (saturated_bounds 4 machine_wordsize).

  Local Existing Instance default_translate_to_fancy.
  Local Instance no_select_size : no_select_size_opt := no_select_size_of_no_select machine_wordsize.
  Local Instance split_mul_to : split_mul_to_opt := split_mul_to_of_should_split_mul machine_wordsize possible_values.
  Local Instance split_multiret_to : split_multiret_to_opt := split_multiret_to_of_should_split_multiret machine_wordsize possible_values.

  (** Note: If you change the name or type signature of this
        function, you will need to update the code in CLI.v *)
  Definition check_args {T} (requests : list string) (res : Pipeline.ErrorT T)
    : Pipeline.ErrorT T
    := check_args_of_list
         (List.map
            (fun v => (true, v))
            [((0 <? s)%Z, Pipeline.Value_not_ltZ "0 < s" 0 s)
             ; ((0 <? Associational.eval c)%Z, Pipeline.Value_not_ltZ "0 < Associational.eval c" 0 (Associational.eval c))
             ; ((0 <? s - Associational.eval c)%Z, Pipeline.Value_not_ltZ "0 < s - Associational.eval c" 0 (s - Associational.eval c))
             ; (negb (s =? 0)%Z, Pipeline.Values_not_provably_distinctZ "s ≠ 0" s 0)
             ; (negb (n =? 0)%nat, Pipeline.Values_not_provably_distinctZ "n ≠ 0" n 0)
             ; ((n =? 4)%Z, Pipeline.Values_not_provably_equalZ "n = 4" n 4)
             ; (0 <? machine_wordsize, Pipeline.Value_not_ltZ "0 < machine_wordsize" 0 machine_wordsize)
             ; (machine_wordsize =? 64, Pipeline.Values_not_provably_equalZ "machine_wordsize = 64" machine_wordsize 64)
             ; ((1 <? n)%nat, Pipeline.Value_not_ltZ "1 < n" 1 n)
             ; (fst (Rows.adjust_s weight (S (S n)) s) =? weight n, Pipeline.Values_not_provably_equalZ "fst (Rows.adjust_s weight (S (S n)) s) = weight n" (fst (Rows.adjust_s weight (S (S n)) s)) (weight n))
             ; (snd (Rows.adjust_s weight (S (S n)) s), Pipeline.Invalid_argument "tmp")
             ; (weight n / s * Associational.eval c <? up_bound, Pipeline.Value_not_ltZ "weight n / s * Associational.eval c < up_bound" (weight n / s * Associational.eval c) up_bound)
         ])
         res.

  Local Ltac use_curve_good_t :=
    repeat first [ use_requests_to_prove_curve_good_t_step
                 | assumption
                 | lia
                 | progress autorewrite with distr_length
                 | progress distr_length ].

  Context (requests : list string)
          (curve_good : check_args requests (Success tt) = Success tt).

  Lemma use_curve_good
    : (n > 1)%nat /\
        s > 0 /\
        Associational.eval c > 0 /\
        s - Associational.eval c <> 0 /\
        machine_wordsize = 64 /\
        base <> 0 /\
        Rows.adjust_s weight (S (S n)) s = (weight n, true) /\
        weight n / s * Associational.eval c < up_bound.
  Proof using curve_good.
    prepare_use_curve_good ().
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { unfold base.
      apply Z.pow_nonzero; use_curve_good_t. }
    { lazymatch goal with
      | |- ?x = _ => rewrite surjective_pairing with (p:=x)
      end.
      congruence. }
  Qed.

  Local Notation evalf := (eval weight n).
  Local Notation weightf := weight.
  Local Notation notations_for_docstring
    := (CorrectnessStringification.dyn_context.cons
          weightf "weight"
          (CorrectnessStringification.dyn_context.cons
             evalf "eval"
             CorrectnessStringification.dyn_context.nil))%string.
  Local Notation "'docstring_with_summary_from_lemma!' summary correctness"
    := (docstring_with_summary_from_lemma_with_ctx!
          notations_for_docstring
          summary
          correctness)
         (only parsing, at level 10, summary at next level, correctness at next level).

  Definition mul
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         possible_values
         (reified_mul_gen
            @ GallinaReify.Reify base
            @ GallinaReify.Reify s
            @ GallinaReify.Reify c
            @ GallinaReify.Reify n)
         (Some boundsn, (Some boundsn, tt))
         (Some boundsn).

  Definition square
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         possible_values
         (reified_square_gen
            @ GallinaReify.Reify base
            @ GallinaReify.Reify s
            @ GallinaReify.Reify c
            @ GallinaReify.Reify n)
         (Some boundsn, tt)
         (Some boundsn).

  Definition smul (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "mul" mul
          (docstring_with_summary_from_lemma!
             (fun fname : string => [text_before_function_name ++ fname ++ " multiplies two field elements."]%string)
             (mul_correct weightf n m boundsn)).

  Definition ssquare (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "square" square
          (docstring_with_summary_from_lemma!
             (fun fname : string => [text_before_function_name ++ fname ++ " squares a field element."]%string)
             (sqr_correct weightf n m boundsn)).

  Local Ltac solve_extra_bounds_side_conditions :=
    cbn [lower upper fst snd] in *; Bool.split_andb; Z.ltb_to_lt; lia.

  Local Ltac prove_correctness _ := Primitives.prove_correctness use_curve_good.

  Lemma mul_correct res
        (Hres : mul = Success res)
    : mul_correct weight n m boundsn (Interp res).
  Proof using curve_good.
    prove_correctness ().
    cbv [evalf weightf weight up_bound] in *.
    match goal with
    | H : machine_wordsize = _ |- _ => rewrite H in *
    end.
    apply (fun pf => @SolinasReduction.SolinasReduction.mulmod_correct (@wprops _ _ pf)); auto; lia.
  Qed.

  Lemma Wf_mul res (Hres : mul = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma square_correct res
        (Hres : square = Success res)
    : sqr_correct weight n m boundsn (Interp res).
  Proof using curve_good.

    prove_correctness ().
    cbv [evalf weightf weight up_bound] in *.
    match goal with
    | H : machine_wordsize = _ |- _ => rewrite H in *
    end.
    apply (fun pf => @SolinasReduction.SolinasReduction.squaremod_correct (@wprops _ _ pf)); auto; lia.
  Qed.

  Lemma Wf_square res (Hres : square = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Section for_stringification.
    Local Open Scope string_scope.
    Local Open Scope list_scope.

    Definition known_functions
      := [("mul", wrap_s smul); ("square", wrap_s ssquare)].

    Definition valid_names : string := Eval compute in String.concat ", " (List.map (@fst _ _) known_functions).

    (** Note: If you change the name or type signature of this
          function, you will need to update the code in CLI.v *)
    Definition Synthesize (comment_header : list string) (function_name_prefix : string) (requests : list string)
      : list (synthesis_output_kind * string * Pipeline.M (list string))
      := Primitives.Synthesize
           machine_wordsize valid_names known_functions (fun _ => nil) all_typedefs!
           check_args
           ((ToString.comment_file_header_block
               (comment_header
                  ++ ["";
                     "Computed values:";
                     ""]%string)))
           function_name_prefix requests.
  End for_stringification.
End __.

Module Export Hints.
#[global]
  Hint Opaque
       mul
  : wf_op_cache.
#[global]
  Hint Immediate
       Wf_mul
  : wf_op_cache.

#[global]
  Hint Opaque
       square
  : wf_op_cache.
#[global]
  Hint Immediate
       Wf_square
  : wf_op_cache.
End Hints.