From Coq Require Import ZArith.ZArith MSets.MSetPositive FSets.FMapPositive
     Strings.String Strings.Ascii Bool.Bool Lists.List Strings.HexString.
From Crypto.Util Require Import
     ListUtil
     Strings.String Strings.Decimal Strings.Show
     ZRange.Operations ZRange.Show
     Option OptionList Bool.Equality.

Require Import Crypto.Util.ZRange.

From Crypto Require Import IR Stringification.Language AbstractInterpretation.ZRange.

Import ListNotations.

Local Open Scope zrange_scope.
Local Open Scope Z_scope.

Import IR.Compilers.ToString.
Import Stringification.Language.Compilers.
Import Stringification.Language.Compilers.Options.
Import Stringification.Language.Compilers.ToString.
Import Stringification.Language.Compilers.ToString.int.Notations.

Module Zig.
  Definition comment_module_header_block := List.map (fun line => "// " ++ line)%string.
  Definition comment_block := List.map (fun line => "// " ++ line)%string.

  Definition header
             {language_naming_conventions : language_naming_conventions_opt}
             {package_namev : package_name_opt}
             {class_namev : class_name_opt}
             (machine_wordsize : Z) (internal_private : bool) (private : bool) (prefix : string) (infos : ToString.ident_infos)
    : list string
    := (["";
         "const std = @import(""std"");";
         "const cast = std.meta.cast;";
         "const mode = std.builtin.mode; // Checked arithmetic is disabled in non-debug modes to avoid side channels"]%string)%list.

  (* Zig natively supports any integer size between 0 and 4096 bits.
     So, we never need to define our own types. *)
  Definition int_type_to_string {language_naming_conventions : language_naming_conventions_opt} (t : ToString.int.type) : string :=
    (if int.is_unsigned t then "u" else "i") ++ Decimal.Z.to_string(ToString.int.bitwidth_of t).

  Definition primitive_type_to_string {language_naming_conventions : language_naming_conventions_opt} (private : bool) (prefix : string) (t : IR.type.primitive)
             (r : option ToString.int.type) : string :=
    match t with
    | IR.type.Zptr => "*"
    | IR.type.Z => ""
    end ++ match r with
           | Some int_t => int_type_to_string int_t
           | None => "ℤ"
           end.

  (* Integer literal to string *)
  Definition int_literal_to_string (prefix : string) (t : IR.type.primitive) (v : BinInt.Z) : string :=
    match t with
    | IR.type.Z => HexString.of_Z v (* Zig can automatically figure out the size of integer literals *)
    | IR.type.Zptr => "@compilerError(""literal address " ++ HexString.of_Z v ++ """);"
    end.

  Import IR.Notations.

  Fixpoint arith_to_string
           {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool)
           (prefix : string) {t} (e : IR.arith_expr t) : string
    := let special_name_ty name ty := ToString.format_special_function_name_ty internal_private prefix name ty in
       let special_name name bw := ToString.format_special_function_name internal_private prefix name false(*unsigned*) bw in
       match e with
       (* integer literals *)
       | (IR.literal v @@@ _) => int_literal_to_string prefix IR.type.Z v
       (* array dereference *)
       | (IR.List_nth n @@@ IR.Var _ v) => "(" ++ v ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "])"
       (* (de)referencing *)
       | (IR.Addr @@@ IR.Var _ v) => "&" ++ v
       | (IR.Dereference @@@ e) => "( " ++ arith_to_string internal_private prefix e ++ ".* )"
       (* bitwise operations *)
       | (IR.Z_shiftr offset @@@ e) =>
         "(" ++ arith_to_string internal_private prefix e ++ " >> " ++ Decimal.Z.to_string offset ++ ")"
       | (IR.Z_shiftl offset @@@ e) =>
         "(" ++ arith_to_string internal_private prefix e ++ " << " ++ Decimal.Z.to_string offset ++ ")"
       | (IR.Z_land @@@ (e1, e2)) =>
         "(" ++ arith_to_string internal_private prefix e1 ++ " & " ++ arith_to_string internal_private prefix e2 ++ ")"
       | (IR.Z_lor @@@ (e1, e2)) =>
         "(" ++ arith_to_string internal_private prefix e1 ++ " | " ++ arith_to_string internal_private prefix e2 ++ ")"
       | (IR.Z_lxor @@@ (e1, e2)) =>
         "(" ++ arith_to_string internal_private prefix e1 ++ " ^ " ++ arith_to_string internal_private prefix e2 ++ ")"
       | (IR.Z_lnot _ @@@ e) => "(~" ++ arith_to_string internal_private prefix e ++ ")"
       (* arithmetic operations *)
       | (IR.Z_add @@@ (x1, x2)) =>
         "(" ++ arith_to_string internal_private prefix x1 ++ " + " ++ arith_to_string internal_private prefix x2 ++ ")"
       | (IR.Z_mul @@@ (x1, x2)) =>
         "(" ++ arith_to_string internal_private prefix x1 ++ " * " ++ arith_to_string internal_private prefix x2 ++ ")"
       | (IR.Z_sub @@@ (x1, x2)) =>
         "(" ++ arith_to_string internal_private prefix x1 ++ " - " ++ arith_to_string internal_private prefix x2 ++ ")"
       | (IR.Z_bneg @@@ e) => "(~" ++ arith_to_string internal_private prefix e ++ ")"
       | (IR.Z_mul_split lg2s @@@ args) =>
         special_name "mulx" lg2s ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_add_with_get_carry lg2s @@@ args) =>
         special_name "addcarryx" lg2s ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_sub_with_get_borrow lg2s @@@ args) =>
         special_name "subborrowx" lg2s ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_zselect ty @@@ args) =>
         special_name_ty "cmovznz" ty ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_value_barrier ty @@@ args) =>
         special_name_ty "value_barrier" ty ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_static_cast int_t @@@ e) =>
         "cast(" ++ primitive_type_to_string internal_private prefix IR.type.Z (Some int_t) ++ ", " ++ arith_to_string internal_private prefix e ++ ")"
       | IR.Var _ v => v
       | IR.Pair A B a b => arith_to_string internal_private prefix a ++ ", " ++ arith_to_string internal_private prefix b
       | (IR.Z_add_modulo @@@ (x1, x2, x3)) => "@compilerError(""addmodulo"");"
       | (IR.List_nth _ @@@ _)
       | (IR.Addr @@@ _)
       | (IR.Z_add @@@ _)
       | (IR.Z_mul @@@ _)
       | (IR.Z_sub @@@ _)
       | (IR.Z_land @@@ _)
       | (IR.Z_lor @@@ _)
       | (IR.Z_lxor @@@ _)
       | (IR.Z_add_modulo @@@ _) => "@compilerError(""bad_arg"");"
       | IR.TT => "@compilerError(""tt"");"
       end%string%Cexpr.

  Definition stmt_to_string
             {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool)
             (prefix : string) (e : IR.stmt) : string :=
    match e with
    | IR.Call val => arith_to_string internal_private prefix val ++ ";"
    | IR.Assign true t sz name val =>
      (* local non-mutable declaration with initialization *)
      "const " ++ name ++ " = " ++ arith_to_string internal_private prefix val ++ ";"
    | IR.Assign false _ sz name val =>
    (* code : name ++ " = " ++ arith_to_string internal_private prefix val ++ ";" *)
      "@compilerError(""trying to assign value to non-mutable variable"");"
    | IR.AssignZPtr name sz val =>
      name ++ ".* = " ++ arith_to_string internal_private prefix val ++ ";"
    | IR.DeclareVar t sz name =>
      "var " ++ name ++ ": " ++ primitive_type_to_string internal_private prefix t sz ++ " = undefined;"
    | IR.Comment lines _ =>
      String.concat String.NewLine (comment_block (ToString.preprocess_comment_block lines))
    | IR.AssignNth name n val =>
      name ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "] = " ++ arith_to_string internal_private prefix val ++ ";"
    end.

  Definition to_strings {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool) (prefix : string) (e : IR.expr) : list string :=
    List.map (stmt_to_string internal_private prefix) e.

  Import Rewriter.Language.Language.Compilers Crypto.Language.API.Compilers IR.OfPHOAS.
  Local Notation tZ := (base.type.type_base base.type.Z).

  Inductive Mode := In | Out.

  Fixpoint to_base_arg_list {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool) (prefix : string) (mode : Mode) {t} : ToString.OfPHOAS.base_var_data t -> list string :=
    match t return base_var_data t -> _ with
    | tZ =>
      let typ := match mode with In => IR.type.Z | Out => IR.type.Zptr end in
      fun '(n, is_ptr, r) => [n ++ ": " ++ primitive_type_to_string internal_private prefix typ r]
    | base.type.prod A B =>
      fun '(va, vb) => (to_base_arg_list internal_private prefix mode va ++ to_base_arg_list internal_private prefix mode vb)%list
    | base.type.list tZ =>
      fun '(n, r, len) =>
        match mode with
        | In => (* arrays for inputs are immutable *)
          [ n ++ ": " ++
              "[" ++ Decimal.Z.to_string (Z.of_nat len) ++ "]" ++ primitive_type_to_string internal_private prefix IR.type.Z r ]
        | Out => (* arrays for outputs are mutable *)
          [ n ++ ": " ++
              "*[" ++ Decimal.Z.to_string (Z.of_nat len) ++ "]" ++ primitive_type_to_string internal_private prefix IR.type.Z r ]
        end
    | base.type.list _ => fun _ => ["@compilerError(""complex list"");"]
    | base.type.option _ => fun _ => ["@compilerError(""option"");"]
    | base.type.unit => fun _ => ["@compilerError(""unit"");"]
    | base.type.type_base t => fun _ => ["@compilerError(""" ++ show false t ++ """);"]%string
    end%string.

  Definition to_arg_list {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool) (prefix : string) (mode : Mode) {t} : var_data t -> list string :=
    match t return var_data t -> _ with
    | type.base t => to_base_arg_list internal_private prefix mode
    | type.arrow _ _ => fun _ => ["@compilerError(""arrow"");"]
    end%string.

  Fixpoint to_arg_list_for_each_lhs_of_arrow {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool) (prefix : string) {t} : type.for_each_lhs_of_arrow var_data t -> list string
    := match t return type.for_each_lhs_of_arrow var_data t -> _ with
       | type.base t => fun _ => nil
       | type.arrow s d
         => fun '(x, xs)
            => to_arg_list internal_private prefix In x ++ to_arg_list_for_each_lhs_of_arrow internal_private prefix xs
       end%list.

  (** * Language-specific numeric conversions to be passed to the PHOAS -> IR translation *)

  Definition Zig_bin_op_natural_output
    : IR.Z_binop -> ToString.int.type * ToString.int.type -> ToString.int.type
    := fun idc '(t1, t2)
       => ToString.int.union t1 t2.

  Definition Zig_bin_op_casts
    : IR.Z_binop -> option ToString.int.type -> ToString.int.type * ToString.int.type -> option ToString.int.type * (option ToString.int.type * option ToString.int.type)
    := fun idc desired_type '(t1, t2)
       => match desired_type with
          | Some desired_type
            => let ct := ToString.int.union t1 t2 in
               let desired_type' := Some (ToString.int.union ct desired_type) in
               (Some desired_type,
                (get_Zcast_up_if_needed desired_type' (Some t1),
                 get_Zcast_up_if_needed desired_type' (Some t2)))
          | None => (None, (None, None))
          end.

  Definition Zig_un_op_casts
    : IR.Z_unop -> option ToString.int.type -> ToString.int.type -> option ToString.int.type * option ToString.int.type
    := fun idc desired_type t
       => match idc with
          | IR.Z_shiftr offset
            =>
            let t' := ToString.int.union_zrange r[0~>2^offset]%zrange t in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type (Some t'),
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed (Some t') (Some t))
          | IR.Z_shiftl offset
            =>
            let rpre_out := match desired_type with
                            | Some rout => Some (ToString.int.union_zrange r[0~>2^offset] (ToString.int.unsigned_counterpart_of rout))
                            | None => Some (ToString.int.of_zrange_relaxed r[0~>2^offset]%zrange)
                            end in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type rpre_out,
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed rpre_out (Some t))
          | IR.Z_lnot ty
            => (
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_value_barrier ty
            => (
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_bneg
            => ((* bneg is !, i.e., takes the argument to 1 if its not zero, and to zero if it is zero; so we don't ever need to cast *)
              None, None)
          end.

  Local Instance ZigLanguageCasts : LanguageCasts :=
    {| bin_op_natural_output := Zig_bin_op_natural_output
       ; bin_op_casts := Zig_bin_op_casts
       ; un_op_casts := Zig_un_op_casts
       ; upcast_on_assignment := true
       ; upcast_on_funcall := true
       ; explicit_pointer_variables := false
    |}.

  Definition to_function_lines {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool) (private : bool) (prefix : string) (name : string)
             {t}
             (f : type.for_each_lhs_of_arrow var_data t * var_data (type.base (type.final_codomain t)) * IR.expr)
    : list string :=
    let '(args, rets, body) := f in
    ((if private then "fn " else "pub fn ") ++ name ++
      "(" ++ String.concat ", " (to_arg_list internal_private prefix Out rets ++ to_arg_list_for_each_lhs_of_arrow internal_private prefix args) ++
      ")" ++ (if private then " callconv(.Inline) " else " ") ++ "void {")%string :: (["    @setRuntimeSafety(mode == .Debug);"; ""]%string)%list ++ (List.map (fun s => "    " ++ s)%string (to_strings internal_private prefix body)) ++ ["}"%string]%list.

  (** In Zig, there is no munging of return arguments (they remain
      passed by pointers), so all variables are live *)
  Local Instance : consider_retargs_live_opt := fun _ _ _ => true.
  Local Instance : rename_dead_opt := fun s => s.
  (** No need to lift declarations to the top *)
  Local Instance : lift_declarations_opt := false.

  Definition ToFunctionLines
             {relax_zrange : relax_zrange_opt}
             {language_naming_conventions : language_naming_conventions_opt}
             (machine_wordsize : Z)
             (do_bounds_check : bool) (internal_private : bool) (private : bool) (prefix : string) (name : string)
             {t}
             (e : API.Expr t)
             (comment : type.for_each_lhs_of_arrow var_data t -> var_data (type.base (type.final_codomain t)) -> list string)
             (name_list : option (list string))
             (inbounds : type.for_each_lhs_of_arrow Compilers.ZRange.type.option.interp t)
             (outbounds : Compilers.ZRange.type.base.option.interp (type.final_codomain t))
    : (list string * ToString.ident_infos) + string :=
    match ExprOfPHOAS do_bounds_check e name_list inbounds with
    | inl (indata, outdata, f) =>
      inl (((List.map (fun s => if (String.length s =? 0)%nat then "///" else ("/// " ++ s))%string (comment indata outdata))
              ++ ["/// Input Bounds:"%string]
              ++ List.map (fun v => "///   "%string ++ v)%string (input_bounds_to_string indata inbounds)
              ++ ["/// Output Bounds:"%string]
              ++ List.map (fun v => "///   "%string ++ v)%string (bound_to_string outdata outbounds)
              ++ to_function_lines internal_private private prefix name (indata, outdata, f))%list,
           IR.ident_infos.collect_infos f)
    | inr nil =>
      inr ("Unknown internal error in converting " ++ name ++ " to Zig")%string
    | inr [err] =>
      inr ("Error in converting " ++ name ++ " to Zig:" ++ String.NewLine ++ err)%string
    | inr errs =>
      inr ("Errors in converting " ++ name ++ " to Zig:" ++ String.NewLine ++ String.concat String.NewLine errs)%string
    end.

  Definition OutputZigAPI : ToString.OutputLanguageAPI :=
    {| ToString.comment_block := comment_block;
       ToString.comment_file_header_block := comment_module_header_block;
       ToString.ToFunctionLines := @ToFunctionLines;
       ToString.header := @header;
       ToString.footer := fun _ _ _ _ _ _ _ _ => [];
       ToString.strip_special_infos machine_wordsize infos := infos |}.

End Zig.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From Coq Require Import List Lia ZArith.
From compcert Require Import Integers Values Clight Memory.
Import ListNotations.

From bpf.comm Require Import LemmaNat Monad.
From bpf.clightlogic Require Import CommonLemma CommonLib Clightlogic CorrectRel.
From bpf.verifier.comm Require Import monad.

From bpf.verifier.synthesismodel Require Import verifier_synthesis.
From bpf.verifier.clightmodel Require Import verifier.
From bpf.verifier.simulation Require Import VerifierSimulation VerifierRel.

(**
Check get_offset.
get_offset
     : int64 -> M int

 *)

Open Scope Z_scope.

Section Get_offset.
  Context {S: special_blocks}.
  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  (* Definition Args : list CompilableType := [stateCompilableType].*)
  Definition args : list Type := [(int64:Type)].
  Definition res : Type := (int:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M state.state res) := get_offset.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_get_offset.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) args :=
    (dcons (fun x => StateLess _ (int64_correct x))
                    (DList.DNil _)).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv state.state := fun x  => StateLess _ (sint32_correct x).

  Instance correct_function_bpf_verifier_get_offset : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.

    unfold f. unfold get_offset.
    correct_forward.

    get_invariant _i.

    unfold eval_inv, int64_correct in c0.
    subst.

    eexists.

    split_and; auto.
    {
      unfold exec_expr. repeat
      match goal with
      | H: ?X = _ |- context [match ?X with _ => _ end] =>
        rewrite H
      end. simpl.
      unfold Cop.sem_shl, Cop.sem_shift; simpl.
      change Int64.iwordsize with (Int64.repr 64).
      change (Int64.ltu (Int64.repr 32) (Int64.repr 64)) with true; simpl.
      unfold Cop.sem_shr; simpl.
      unfold Cop.sem_shift; simpl.
      change Int64.iwordsize with (Int64.repr 64).
      change (Int64.ltu (Int64.repr 48) (Int64.repr 64)) with true; simpl.
      unfold Cop.sem_cast; simpl.
      reflexivity.
    }
    {
      unfold match_res, sint32_correct, BinrBPF.get_offset; simpl.
      split; [reflexivity | apply Int.signed_range].
    }
    unfold Cop.sem_cast; simpl.
    reflexivity.
  Qed.

End Get_offset.
Close Scope Z_scope.

Existing Instance correct_function_bpf_verifier_get_offset.


Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Require Import ProD3.examples.cms.ConModel.
Require Import ProD3.examples.cms.common.
Require Import ProD3.examples.cms.ModelRepr.
Require Import ProD3.examples.cms.verif_Win1.
Require Import ProD3.examples.cms.verif_Win2.
Require Import ProD3.examples.cms.verif_Win3.
Require Import ProD3.examples.cms.verif_CMS_1.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_1_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_2_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_3_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_4_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_5_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_clear_index_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_clear_window_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_1_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_2_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_3_body) : func_specs.

Definition P4_bf2_win_md_t_insert (f cf if' : Z) (new_clear_index : Sval) (is : list Sval) :=
  if f=? cf then
    P4_bf2_win_md_t (P4Bit 8 CLEAR) (Zrepeat new_clear_index 5)
  else if f=? if' then
    P4_bf2_win_md_t (P4Bit 8 INSERT) is
  else
    P4_bf2_win_md_t (P4Bit 8 NOOP) is.

Definition tbl_set_win_insert_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"];
               ["act_set_clear_win_1"; "api_1"];
               ["act_set_clear_win_1"; "api_2"];
               ["act_set_clear_win_1"; "api_3"];
               ["act_set_clear_win_2"; "api_1"];
               ["act_set_clear_win_2"; "api_2"];
               ["act_set_clear_win_2"; "api_3"];
               ["act_set_clear_win_3"; "api_1"];
               ["act_set_clear_win_3"; "api_2"];
               ["act_set_clear_win_3"; "api_3"];
               ["act_set_clear_win_4"; "api_1"];
               ["act_set_clear_win_4"; "api_2"];
               ["act_set_clear_win_4"; "api_3"];
               ["act_set_clear_win_5"; "api_1"];
               ["act_set_clear_win_5"; "api_2"];
               ["act_set_clear_win_5"; "api_3"]]) []
    WITH (timer : Z * bool) (clear_index_1 hash_index_1 hash_index_2 hash_index_3 hash_index_4 hash_index_5 : Sval)
      (H_timer : 0 <= fst timer < frame_tick_tocks * num_frames),
      PRE
        (ARG []
        (MEM [(["api"], P4Bit 8 INSERT);
              (["ds_md"], ValBaseStruct
                 [("clear_window", P4Bit 16 (fst timer));
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("hash_index_4", hash_index_4);
                  ("hash_index_5", hash_index_5);
                  ("win_1", P4_bf2_win_md_t_);
                  ("win_2", P4_bf2_win_md_t_);
                  ("win_3", P4_bf2_win_md_t_)])]
        (EXT [])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (let cf := get_clear_frame timer in
        let if' := get_insert_frame cf in
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", P4Bit 16 (fst timer));
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("hash_index_4", hash_index_4);
                  ("hash_index_5", hash_index_5);
                  ("win_1", P4_bf2_win_md_t_insert 0 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3; hash_index_4; hash_index_5]);
                  ("win_2", P4_bf2_win_md_t_insert 1 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3; hash_index_4; hash_index_5]);
                  ("win_3", P4_bf2_win_md_t_insert 2 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3; hash_index_4; hash_index_5])])]
        (EXT [])))))%arg_ret_assr.

Lemma tbl_set_win_insert_body :
  func_sound ge tbl_set_win_fd nil tbl_set_win_insert_spec.
Proof.
  start_function; elim_trivial_cases.
  - replace (get_clear_frame timer) with 0. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_1_body.
    { entailer. }
    { entailer. }
  - replace (get_clear_frame timer) with 1. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_2_body.
    { entailer. }
    { entailer. }
  - replace (get_clear_frame timer) with 2. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_3_body.
    { entailer. }
    { entailer. }
  - lia.
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_set_win_insert_body) : func_specs.

Definition cms_insert := @cms_insert num_frames num_rows num_slots H_num_frames H_num_rows H_num_slots
  frame_tick_tocks.

Definition CMS_insert_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD None [p]
    WITH (key : Val) (tstamp : Z) (cf : cms num_frames num_rows num_slots),
      PRE
        (ARG [eval_val_to_sval key; P4Bit 8 INSERT; P4Bit 48 tstamp; P4Bit_ value_w]
        (MEM []
        (EXT [cms_repr p index_w panes rows cf])))
      POST
        (ARG_RET [P4Bit_ value_w] ValBaseNull
        (MEM []
        (EXT [cms_repr p index_w panes rows (cms_insert cf (Z.odd (tstamp/tick_time)) (hashes key))]))).

Lemma CMS_insert_body :
  func_sound ge CMS_fd nil CMS_insert_spec.
Proof.
  Time start_function.
  destruct cf as [[ps ?H] ? ?].
  unfold cms_repr.
  cbn [proj1_sig] in *.
  destruct_list ps.
  normalize_EXT.
  Time step.
  Time step_call tbl_hash_index_1_body.
  { entailer. }
  Intros _.
  step_call tbl_hash_index_2_body.
  { entailer. }
  Time simpl_assertion.
  Intros _.
  step_call tbl_hash_index_3_body.
  { entailer. }
  Time simpl_assertion.
  Intros _.
  step_call tbl_hash_index_4_body.
  { entailer. }
  Time simpl_assertion.
  Intros _.
  step_call tbl_hash_index_5_body.
  { entailer. }
  Time simpl_assertion.
  Intros _.
  set (is := (exist _ [hash1 key; hash2 key; hash3 key; hash4 key; hash5 key] eq_refl : listn Z num_rows)).
  set (clear_is := (exist _ (Zrepeat cms_clear_index num_rows) eq_refl : listn Z num_rows)).
  assert (Forall (fun i : Z => 0 <= i < num_slots) (`is)). {
    repeat first [apply Forall_cons | apply Forall_nil].
    all : apply Z.mod_pos_bound; lia.
  }
  P4assert (0 <= cms_clear_index < num_slots). {
    unfold fil_clear_index_repr.
    Intros i'.
    normalize_EXT.
    Intros_prop.
    apply ext_implies_prop_intro.
    subst.
    apply Z.mod_pos_bound.
    lia.
  }
  assert (Forall (fun i : Z => 0 <= i < num_slots) (`clear_is)). {
    repeat first [
      assumption
    | constructor
    ].
  }
  step_call tbl_clear_index_body.
  { entailer. }
  Time simpl_assertion.
  Intros _.
  step_call tbl_clear_window_body.
  { entailer. }
  Intros _.
  set (new_timer := update_timer cms_timer (Z.odd (tstamp / tick_time))).
  P4assert (0 <= fst new_timer < num_frames * frame_tick_tocks).
  { unfold timer_repr.
    normalize_EXT.
    Intros_prop.
    apply ext_implies_prop_intro.
    auto.
  }
  step_call tbl_set_win_insert_body.
  { entailer. }
  { auto. }
  Intros _.
  (* unfold and fold in the post condition *)
  unfold cms_insert, ConModel.cms_insert.
  unfold proj1_sig.
  fold new_timer.
  replace (exist (fun i : list Z => Zlength i = num_rows) (Zrepeat cms_clear_index num_rows) _) with clear_is. 2 : {
    apply subset_eq_compat. auto.
  }
  assert (0 <= get_clear_frame new_timer < num_frames). {
    unfold ConModel.get_clear_frame.
    split.
    - apply Z.div_le_lower_bound; lia.
    - apply Z.div_lt_upper_bound; lia.
  }
  destruct (get_clear_frame new_timer =? 0) eqn:?.
  { replace (get_clear_frame new_timer) with 0 by lia.
    step_call verif_Win1.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_call tbl_merge_wins_1_body.
    { entailer. }
    { reflexivity. }
    { reflexivity. }
    Intros _.
    simpl_assertion.
    step_into.
    { hoare_func_table; elim_trivial_cases.
      { clear -H5; lia. }
      table_action NoAction_body.
      { entailer. }
      { apply arg_ret_implies_refl. }
    }
    { reflexivity. }
    { reflexivity. }
    simpl_assertion.
    entailer.
  }
  destruct (get_clear_frame new_timer =? 1) eqn:?.
  { replace (get_clear_frame new_timer) with 1 by lia.
    step_call verif_Win1.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_call tbl_merge_wins_1_body.
    { entailer. }
    { reflexivity. }
    { reflexivity. }
    Intros _.
    simpl_assertion.
    step_into.
    { hoare_func_table; elim_trivial_cases.
      { clear -H5; lia. }
      table_action NoAction_body.
      { entailer. }
      { apply arg_ret_implies_refl. }
    }
    { reflexivity. }
    { reflexivity. }
    simpl_assertion.
    entailer.
  }
  destruct (get_clear_frame new_timer =? 2) eqn:?.
  { replace (get_clear_frame new_timer) with 2 by lia.
    step_call verif_Win1.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_call tbl_merge_wins_1_body.
    { entailer. }
    { reflexivity. }
    { reflexivity. }
    Intros _.
    simpl_assertion.
    step_into.
    { hoare_func_table; elim_trivial_cases.
      { clear -H5; lia. }
      table_action NoAction_body.
      { entailer. }
      { apply arg_ret_implies_refl. }
    }
    { reflexivity. }
    { reflexivity. }
    simpl_assertion.
    entailer.
  }
  destruct (get_clear_frame new_timer =? 3) eqn:?.
  { replace (get_clear_frame new_timer) with 3 by lia.
    step_call verif_Win1.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_call tbl_merge_wins_1_body.
    { entailer. }
    { reflexivity. }
    { reflexivity. }
    Intros _.
    simpl_assertion.
    step_into.
    { hoare_func_table; elim_trivial_cases.
      { clear -H5; lia. }
      table_action NoAction_body.
      { entailer. }
      { apply arg_ret_implies_refl. }
    }
    { reflexivity. }
    { reflexivity. }
    simpl_assertion.
    entailer.
  }
  lia.
Time Qed.


Require Import FunctionalExtensionality.
Require Import Relations.
Require Import EquivDec.
Require Import Equality.
Require Import List.
Require Import Bool.
Require Import Lia.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import EquivDec.

From sflib Require Import sflib.
From Paco Require Import paco.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.

Require Import PromisingArch.promising.Promising.

Require Import PromisingArch.mapping.RMWLang.
Require Import PromisingArch.mapping.RMWPromising.

Set Implicit Arguments.

Section SIM_EU.
  Variable tid: Id.t.

  Definition SIM_EU: Type := RMWExecUnit.t (A:=unit) -> ExecUnit.t (A:=unit) -> Prop.

  Definition _sim_eu (sim_eu: SIM_EU)
             (eu1_src: RMWExecUnit.t (A:=unit)) (eu1_tgt: ExecUnit.t (A:=unit)): Prop :=
    (<<TERMINAL:
      forall (TERMINAL_TGT: ExecUnit.is_terminal eu1_tgt),
      exists eu2_src,
        (<<STEPS_SRC: rtc (RMWExecUnit.state_step None tid) eu1_src eu2_src>>) /\
        (<<TERMINAL_SRC: RMWExecUnit.is_terminal eu2_src>>) /\
        (<<MEMORY2: RMWExecUnit.mem eu2_src = ExecUnit.mem eu1_tgt>>)>>) /\
    (<<STEP:
      forall eu2_tgt
        (STEP_TGT: ExecUnit.state_step tid eu1_tgt eu2_tgt),
      exists eu2_src,
        (<<STEP_SRC: rtc (RMWExecUnit.state_step None tid) eu1_src eu2_src>>) /\
        (<<SIM: sim_eu eu2_src eu2_tgt>>)>>)
  .
  #[local] Hint Unfold _sim_eu: paco.

  Lemma sim_eu_monotone: monotone2 _sim_eu.
  Proof.
    ii. red in IN. des.
    red. esplits; eauto. i.
    exploit STEP; eauto. i. des.
    esplits; eauto.
  Qed.
  #[local] Hint Resolve sim_eu_monotone: paco.

  Definition sim_eu := paco2 _sim_eu bot2.
End SIM_EU.
Arguments sim_eu [_] _ _.
#[export] Hint Resolve sim_eu_monotone: paco.

Lemma sim_eu_state_step
      tid eu1_src eu1_tgt eu2_tgt
      (SIM: @sim_eu tid eu1_src eu1_tgt)
      (STEP_TGT: ExecUnit.state_step tid eu1_tgt eu2_tgt):
  exists eu2_src,
    (<<STEP_SRC: rtc (RMWExecUnit.state_step None tid) eu1_src eu2_src>>) /\
    (<<SIM: @sim_eu tid eu2_src eu2_tgt>>).
Proof.
  punfold SIM. r in SIM. des.
  exploit STEP; eauto. i. des.
  esplits; eauto.
  inv SIM; ss.
Qed.

Lemma sim_eu_rtc_state_step
      tid eu1_src eu1_tgt eu2_tgt
      (SIM: @sim_eu tid eu1_src eu1_tgt)
      (STEPS_TGT: rtc (ExecUnit.state_step tid) eu1_tgt eu2_tgt):
  exists eu2_src,
    (<<STEP_SRC: rtc (RMWExecUnit.state_step None tid) eu1_src eu2_src>>) /\
    (<<SIM: @sim_eu tid eu2_src eu2_tgt>>).
Proof.
  revert eu1_src SIM.
  induction STEPS_TGT; i; eauto.
  exploit sim_eu_state_step; try exact H; eauto. i. des.
  exploit IHSTEPS_TGT; eauto. i. des.
  esplits; [|eauto]. etrans; eauto.
Qed.

Lemma sim_eu_terminal
      tid eu1_src eu1_tgt
      (SIM: @sim_eu tid eu1_src eu1_tgt)
      (TERMINAL_TGT: ExecUnit.is_terminal eu1_tgt):
  exists eu2_src,
    (<<STEP_SRC: rtc (RMWExecUnit.state_step None tid) eu1_src eu2_src>>) /\
    (<<TERMINAL_SRC: RMWExecUnit.is_terminal eu2_src>>).
Proof.
  punfold SIM. r in SIM. des.
  exploit TERMINAL; eauto. i. des. eauto.
Qed.

Fixpoint rmw_to_llsc_stmt (tmp1 tmp2: Id.t) (stmt: rmw_stmtT): list stmtT :=
  match stmt with
  | rmw_stmt_instr rmw_instr_skip =>
      [stmt_instr instr_skip]
  | rmw_stmt_instr (rmw_instr_assign lhs rhs) =>
      [stmt_instr (instr_assign lhs rhs)]
  | rmw_stmt_instr (rmw_instr_load ord res eloc) =>
      [stmt_instr (instr_load false ord res eloc)]
  | rmw_stmt_instr (rmw_instr_store ord eloc eval) =>
      [stmt_instr (instr_store false ord tmp1 eloc eval)]
  | rmw_stmt_instr (rmw_instr_fadd ordr ordw res eloc eadd) =>
      [stmt_dowhile
         [stmt_instr (instr_load true ordr tmp1 eloc);
          stmt_instr (instr_store true ordw tmp2 eloc (expr_op2 op_add (expr_reg tmp1) eadd))]
         (expr_reg tmp2);
       stmt_if (expr_reg tmp1) [] [];
       stmt_instr (instr_assign res (expr_reg tmp1))]
  | rmw_stmt_instr (rmw_instr_dmb rr rw wr ww) =>
      [stmt_instr (instr_barrier (Barrier.dmb rr rw wr ww))]
  | rmw_stmt_if cond s1 s2 =>
      [stmt_if cond
               (List.fold_right (@List.app _) [] (List.map (rmw_to_llsc_stmt tmp1 tmp2) s1))
               (List.fold_right (@List.app _) [] (List.map (rmw_to_llsc_stmt tmp1 tmp2) s2))]
  | rmw_stmt_dowhile s cond =>
      [stmt_dowhile
         (List.fold_right (@List.app _) [] (List.map (rmw_to_llsc_stmt tmp1 tmp2) s)) cond]
  end.

Definition rmw_to_llsc_stmts (tmp1 tmp2: Id.t) (stmts: list rmw_stmtT): list stmtT :=
  List.fold_right (@List.app _) [] (List.map (rmw_to_llsc_stmt tmp1 tmp2) stmts).

Inductive fresh (regs: IdSet.t): forall (stmt: rmw_stmtT), Prop :=
| fresh_instr
    i
    (FRESH: IdSet.disjoint regs (regs_of_rmw_instr i)):
  fresh regs (rmw_stmt_instr i)
| fresh_if
    cond s1 s2
    (FRESH_COND: IdSet.disjoint regs (regs_of_expr cond))
    (FRESH_STMT1: List.Forall (fresh regs) s1)
    (FRESH_STMT2: List.Forall (fresh regs) s2):
  fresh regs (rmw_stmt_if cond s1 s2)
| fresh_dowhile
    s cond
    (FRESH_STMT: List.Forall (fresh regs) s)
    (FRESH_COND: IdSet.disjoint regs (regs_of_expr cond)):
  fresh regs (rmw_stmt_dowhile s cond)
.

Definition rmw_to_llsc_program (p_src: rmw_program) (p_tgt: program): Prop :=
  forall tid, exists tmp1 tmp2,
    option_rel
      (fun stmts_src stmts_tgt =>
         (<<TMP: ~ (tmp1 = tmp2)>>) /\
         (<<FRESH: List.Forall (fresh (IdSet.add tmp2 (IdSet.singleton tmp1))) stmts_src>>) /\
         (<<STMTS: stmts_tgt = rmw_to_llsc_stmts tmp1 tmp2 stmts_src>>))
      (IdMap.find tid p_src) (IdMap.find tid p_tgt).

Variant sim_val (v_src v_tgt: ValA.t (A:=View.t (A:=unit))): Prop :=
| sim_val_intro
    (VAL: ValA.val v_src = ValA.val v_tgt)
    (ANNOT: le (ValA.annot v_src) (ValA.annot v_tgt))
.
#[export] Hint Constructors sim_val: core.

#[export] Program Instance sim_val_PreOrder: PreOrder sim_val.
Next Obligation.
  ii. destruct x. econs; ss. refl.
Qed.
Next Obligation.
  ii. inv H. inv H0.
  destruct x, y, z. ss.
  econs; ss; try congr.
  etrans; eauto.
Qed.

Lemma sim_val_sem_op2
      op2 v1_src v2_src v1_tgt v2_tgt
      (SIM1: sim_val v1_src v1_tgt)
      (SIM2: sim_val v2_src v2_tgt):
  sim_val (sem_op2 op2 v1_src v2_src) (sem_op2 op2 v1_tgt v2_tgt).
Proof.
  inv SIM1. inv SIM2.
  unfold sem_op2. econs; s; try congr.
  eapply join_le; try eapply View.order; ss.
Qed.

Definition sim_rmap (regs: IdSet.t) (rmap_src rmap_tgt: RMap.t (A:=View.t (A:=unit))): Prop :=
  forall r (NEQ: ~ IdSet.In r regs),
    sim_val (RMap.find r rmap_src) (RMap.find r rmap_tgt).

#[export] Program Instance sim_rmap_PreOrder regs: PreOrder (sim_rmap regs).
Next Obligation.
  ii. refl.
Qed.
Next Obligation.
  ii. etrans; eauto.
Qed.

Lemma sim_rmap_sem_expr
      regs rmap_src rmap_tgt
      expr
      (SIM: sim_rmap regs rmap_src rmap_tgt)
      (EXPR: IdSet.disjoint regs (regs_of_expr expr)):
  sim_val (sem_expr rmap_src expr) (sem_expr rmap_tgt expr).
Proof.
  revert EXPR.
  induction expr; i; ss.
  - refl.
  - apply SIM. ii.
    eapply EXPR; eauto.
    eapply IdSet.singleton_2. ss.
  - apply IHexpr in EXPR. inv EXPR.
    unfold sem_op1. econs; s; congr.
  - exploit IHexpr1; ii.
    { eauto using IdSet.union_2. }
    exploit IHexpr2; ii.
    { eauto using IdSet.union_3. }
    inv x0. inv x1.
    unfold sem_op2. econs; s; try congr.
    eapply join_le; try eapply View.order; ss.
Qed.

Lemma sim_rmap_add
      regs rmap_src rmap_tgt
      r v_src v_tgt
      (RMAP: sim_rmap regs rmap_src rmap_tgt)
      (VAL: sim_val v_src v_tgt):
  sim_rmap regs (RMap.add r v_src rmap_src) (RMap.add r v_tgt rmap_tgt).
Proof.
  ii. do 2 rewrite RMap.add_o.
  condtac; ss; eauto.
Qed.

Lemma sim_rmap_add_l
      regs rmap_src rmap_tgt
      r v
      (RMAP: sim_rmap regs rmap_src rmap_tgt)
      (IN: IdSet.In r regs):
  sim_rmap regs (RMap.add r v rmap_src) rmap_tgt.
Proof.
  ii. rewrite RMap.add_o.
  condtac; ss; eauto. inversion e. congr.
Qed.

Lemma sim_rmap_add_r
      regs rmap_src rmap_tgt
      r v
      (RMAP: sim_rmap regs rmap_src rmap_tgt)
      (IN: IdSet.In r regs):
  sim_rmap regs rmap_src (RMap.add r v rmap_tgt).
Proof.
  ii. rewrite RMap.add_o.
  condtac; ss; eauto. inversion e. congr.
Qed.

Variant sim_fwditem (fwd_src fwd_tgt: FwdItem.t (A:=unit)): Prop :=
| sim_fwditem_intro
    (TS: FwdItem.ts fwd_src = FwdItem.ts fwd_tgt)
    (VIEW: le (FwdItem.view fwd_src) (FwdItem.view fwd_tgt))
    (EX: FwdItem.ex fwd_src = FwdItem.ex fwd_tgt)
.
#[export] Hint Constructors sim_fwditem: core.

#[export] Program Instance sim_fwditem_PreOrder: PreOrder sim_fwditem.
Next Obligation.
  ii. destruct x. econs; ss. refl.
Qed.
Next Obligation.
  ii. inv H. inv H0.
  destruct x, y, z. ss.
  econs; ss; try congr.
  etrans; eauto.
Qed.

Variant sim_exbank (ex_src ex_tgt: Exbank.t (A:=unit)): Prop :=
| sim_exbank_intro
    (LOC: Exbank.loc ex_src = Exbank.loc ex_tgt)
    (TS: Exbank.ts ex_src = Exbank.ts ex_tgt)
    (VIEW: le (Exbank.view ex_src) (Exbank.view ex_tgt))
.
#[export] Hint Constructors sim_exbank: core.

#[export] Program Instance sim_exbank_PreOrder: PreOrder sim_exbank.
Next Obligation.
  ii. destruct x. econs; ss. refl.
Qed.
Next Obligation.
  ii. inv H. inv H0.
  destruct x, y, z. ss.
  econs; ss; try congr.
  etrans; eauto.
Qed.

Lemma sim_fwditem_read_view
      fwd_src fwd_tgt
      (SIM: sim_fwditem fwd_src fwd_tgt):
  forall ts ord,
    le (FwdItem.read_view fwd_src ts ord) (FwdItem.read_view fwd_tgt ts ord).
Proof.
  inv SIM. i. unfold FwdItem.read_view.
  rewrite TS, EX. condtac; ss. refl.
Qed.

Variant sim_local (lc_src lc_tgt: Local.t (A:=unit)): Prop :=
| sim_local_intro
    (COH: le lc_src.(Local.coh) lc_tgt.(Local.coh))
    (VRN: le lc_src.(Local.vrn) lc_tgt.(Local.vrn))
    (VWN: le lc_src.(Local.vwn) lc_tgt.(Local.vwn))
    (VRO: le lc_src.(Local.vro) lc_tgt.(Local.vro))
    (VWO: le lc_src.(Local.vwo) lc_tgt.(Local.vwo))
    (VCAP: le lc_src.(Local.vcap) lc_tgt.(Local.vcap))
    (VREL: le lc_src.(Local.vrel) lc_tgt.(Local.vrel))
    (FWDBANK: forall loc, sim_fwditem (lc_src.(Local.fwdbank) loc) (lc_tgt.(Local.fwdbank) loc))
    (PROMISES: Local.promises lc_src = Local.promises lc_tgt)
.
#[export] Hint Constructors sim_local: core.

#[export] Program Instance sim_local_PreOrder: PreOrder sim_local.
Next Obligation.
  ii. destruct x. econs; refl.
Qed.
Next Obligation.
  ii. inv H. inv H0.
  destruct x, y, z; ss.
  econs; ss; try refl; etrans; eauto.
Qed.

Lemma le_latest
      loc ts view_src view_tgt mem
      (LE: view_src <= view_tgt)
      (LATEST: Memory.latest loc ts view_tgt mem):
  Memory.latest loc ts view_src mem.
Proof.
  unfold Memory.latest, Memory.no_msgs in *. i.
  eapply LATEST; eauto. etrans; eauto.
Qed.

Ltac sim_viewtac :=
  repeat
    (try match goal with
         | [|- orderC _ _] => (try apply View.order); (try apply Time.order)
         | [|- le ?v ?v] => refl
         | [|- View._le ?v ?v] => refl
         | [|- le (join _ _) (join _ _)] => eapply join_le
         | [|- le (View._join _ _) (View._join _ _)] => eapply join_le
         | [|- View._le (join _ _) (join _ _)] => eapply join_le
         | [|- View._le (View._join _ _) (View._join _ _)] => eapply join_le
         | [|- (join _ _) <= (join _ _)] => eapply join_le
         | [|- le (ifc ?c _) (ifc ?c _)] =>
             let cond := fresh "COND" in destruct c eqn:cond; ss
         | [|- View._le (ifc ?c _) (ifc ?c _)] =>
             let cond := fresh "COND" in destruct c eqn:cond; ss
         | [|- le (fun_add _ _ _) (fun_add _ _ _)] => ii; unfold fun_add
         | [|- ?rel (if ?c then _ else _) (if ?c then _ else _)] =>
             let cond := fresh "COND" in destruct c eqn:cond; ss
         | [|- le (FwdItem.read_view _ _ _) (FwdItem.read_view _ _ _)] => eapply sim_fwditem_read_view
         | [|- View._le (FwdItem.read_view _ _ _) (FwdItem.read_view _ _ _)] => eapply sim_fwditem_read_view
         | [|- View.ts ?a <= View.ts ?b] =>
             cut (le a b);
             try (let h := fresh "X" in intro h; apply h)
         | [H: (le ?a ?b) |- le (?a ?loc) (?b ?loc)] => apply H
         | [|- sim_fwditem (fun_add _ _ _ _) (fun_add _ _ _ _)] => unfold fun_add
         | [|- sim_fwditem (FwdItem.mk _ _ _) (FwdItem.mk _ _ _)] => econs
         end;
     ss; eauto; i).

Lemma sim_local_read
      ex ord vloc_tgt res_tgt ts lc1_tgt mem_tgt lc2_tgt
      vloc_src mem_src lc1_src
      (LOCAL: sim_local lc1_src lc1_tgt)
      (MEMORY: mem_src = mem_tgt)
      (VLOC: sim_val vloc_src vloc_tgt)
      (STEP_TGT: Local.read ex ord vloc_tgt res_tgt ts lc1_tgt mem_tgt lc2_tgt):
  exists res_src lc2_src,
    (<<STEP_SRC: Local.read ex ord vloc_src res_src ts lc1_src mem_src lc2_src>>) /\
    (<<RES: sim_val res_src res_tgt>>) /\
    (<<LOCAL2: sim_local lc2_src lc2_tgt>>) /\
    (<<EX_TRUE: ex = true -> option_rel sim_exbank lc2_src.(Local.exbank) lc2_tgt.(Local.exbank)>>) /\
    (<<EX_FALSE: ex = false -> lc1_src.(Local.exbank) = lc2_src.(Local.exbank)>>).
Proof.
  destruct lc1_src, lc1_tgt. inv LOCAL. ss.
  destruct vloc_src, vloc_tgt. inv VLOC. ss. subst.
  inv STEP_TGT. ss.
  esplits.
  - econs; eauto; ss.
    + eapply le_latest; try exact COH0. sim_viewtac.
    + eapply le_latest; try exact LATEST. sim_viewtac.
  - ss. econs; ss. sim_viewtac.
  - s. econs; ss; sim_viewtac.
  - s. i. subst. econs; ss. sim_viewtac.
  - s. i. subst. ss.
Qed.

Lemma sim_local_fulfill
      ex ord vloc_tgt vval_tgt res ts tid view_pre_tgt lc1_tgt mem_tgt lc2_tgt
      vloc_src vval_src mem_src lc1_src
      (LOCAL: sim_local lc1_src lc1_tgt)
      (MEMORY: mem_src = mem_tgt)
      (VLOC: sim_val vloc_src vloc_tgt)
      (VVAL: sim_val vval_src vval_tgt)
      (EXBANK: ex = true -> option_rel sim_exbank (Local.exbank lc1_src) (Local.exbank lc1_tgt))
      (STEP_TGT: Local.fulfill ex ord vloc_tgt vval_tgt res ts tid view_pre_tgt lc1_tgt mem_tgt lc2_tgt):
  exists view_pre_src lc2_src,
    (<<STEP_SRC: Local.fulfill ex ord vloc_src vval_src res ts tid view_pre_src lc1_src mem_src lc2_src>>) /\
    (<<VIEW_PRE_SRC: le view_pre_src view_pre_tgt>>) /\
    (<<LOCAL2: sim_local lc2_src lc2_tgt>>) /\
    (<<EXBANK: ex = false -> lc1_src.(Local.exbank) = lc2_src.(Local.exbank)>>).
Proof.
  destruct lc1_src, lc1_tgt. inv LOCAL. ss.
  destruct vloc_src, vloc_tgt. inv VLOC. ss. subst.
  destruct vval_src, vval_tgt. inv VVAL. ss. subst.
  inv STEP_TGT. ss.
  inv WRITABLE. ss.
  esplits.
  - econs; eauto; ss.
    + econs; eauto; ss.
      * eapply Nat.le_lt_trans; try exact COH0. sim_viewtac.
      * eapply Nat.le_lt_trans; try exact EXT. sim_viewtac.
        destruct ex; ss.
        destruct exbank, exbank0; ss; try refl.
        apply EXBANK. ss.
      * destruct ex; ss. i.
        exploit EX; eauto. i. des. subst.
        exploit EXBANK; eauto. i. destruct exbank; ss.
        esplits; eauto.
        inv x0. rewrite LOC, TS. ss.
    + ss.
  - s. sim_viewtac.
    destruct ex; ss.
    destruct exbank, exbank0; ss; try refl.
    apply EXBANK. ss.
  - s. econs; ss; sim_viewtac.
  - s. i. subst. ss.
Qed.

Lemma sim_local_isb
      lc1_tgt lc2_tgt
      lc1_src
      (LOCAL: sim_local lc1_src lc1_tgt)
      (STEP_TGT: Local.isb lc1_tgt lc2_tgt):
  exists lc2_src,
    (<<STEP_SRC: Local.isb lc1_src lc2_src>>) /\
    (<<LOCAL2: sim_local lc2_src lc2_tgt>>) /\
    (<<EXBANK: lc1_src.(Local.exbank) = lc2_src.(Local.exbank)>>).
Proof.
  destruct lc1_src, lc1_tgt. inv LOCAL. ss.
  inv STEP_TGT. ss.
  esplits.
  - econs; ss.
  - econs; ss; sim_viewtac.
  - ss.
Qed.

Lemma sim_local_dmb
      rr rw wr ww lc1_tgt lc2_tgt
      lc1_src
      (LOCAL: sim_local lc1_src lc1_tgt)
      (STEP_TGT: Local.dmb rr rw wr ww lc1_tgt lc2_tgt):
  exists lc2_src,
    (<<STEP_SRC: Local.dmb rr rw wr ww lc1_src lc2_src>>) /\
    (<<LOCAL2: sim_local lc2_src lc2_tgt>>) /\
    (<<EXBANK: lc1_src.(Local.exbank) = lc2_src.(Local.exbank)>>).
Proof.
  destruct lc1_src, lc1_tgt. inv LOCAL. ss.
  inv STEP_TGT. ss.
  esplits.
  - econs; ss.
  - econs; ss; sim_viewtac.
  - ss.
Qed.

Lemma sim_local_control
      (ctrl_tgt: View.t (A:=unit)) lc1_tgt lc2_tgt
      ctrl_src lc1_src
      (LOCAL: sim_local lc1_src lc1_tgt)
      (CTRL: le ctrl_src ctrl_tgt)
      (STEP_TGT: Local.control ctrl_tgt lc1_tgt lc2_tgt):
  exists lc2_src,
    (<<STEP_SRC: Local.control ctrl_src lc1_src lc2_src>>) /\
    (<<LOCAL2: sim_local lc2_src lc2_tgt>>) /\
    (<<EXBANK: lc1_src.(Local.exbank) = lc2_src.(Local.exbank)>>).
Proof.
  destruct lc1_src, lc1_tgt. inv LOCAL. ss.
  inv STEP_TGT. ss.
  esplits.
  - econs; ss.
  - econs; ss; sim_viewtac.
  - ss.
Qed.

Lemma read_sim_local
      ex ord vloc res ts lc1 mem (lc2: Local.t (A:=unit))
      (READ: Local.read ex ord vloc res ts lc1 mem lc2):
  sim_local lc1 lc2.
Proof.
  inv READ. econs; ss;
    try apply join_l; try refl.
  ii. unfold fun_add. condtac; try refl.
  inversion e. subst. apply join_l.
Qed.

Lemma unfold_rmw_to_llsc_stmts
      tmp1 tmp2 s stmts:
  rmw_to_llsc_stmts tmp1 tmp2 (s :: stmts) =
  (rmw_to_llsc_stmt tmp1 tmp2 s) ++ rmw_to_llsc_stmts tmp1 tmp2 stmts.
Proof.
   ss.
Qed.

Lemma fold_right_app
      A (l1 l2: list (list A)):
  fold_right (@List.app _) [] l1 ++ fold_right (@List.app _) [] l2 =
  fold_right (@List.app _) [] (l1 ++ l2).
Proof.
  induction l1; ss.
  rewrite <- app_assoc.
  rewrite IHl1. ss.
Qed.

Section RMWtoLLSC.
  Hypothesis ARCH: arch = armv8.

  Lemma rmw_to_llsc_sim_eu
        tid tmp1 tmp2
        stmts_src rmap_src lc_src mem_src
        stmts_tgt rmap_tgt lc_tgt mem_tgt
        (TMP: tmp1 <> tmp2)
        (FRESH: List.Forall (fresh (IdSet.add tmp2 (IdSet.singleton tmp1))) stmts_src)
        (STMTS: stmts_tgt = rmw_to_llsc_stmts tmp1 tmp2 stmts_src)
        (RMAP: sim_rmap (IdSet.add tmp2 (IdSet.singleton tmp1)) rmap_src rmap_tgt)
        (LOCAL: sim_local lc_src lc_tgt)
        (EXBANK: lc_src.(Local.exbank) = None)
        (MEMORY: mem_src = mem_tgt):
    @sim_eu tid
            (RMWExecUnit.mk (RMWState.mk stmts_src rmap_src) lc_src mem_src)
            (ExecUnit.mk (State.mk stmts_tgt rmap_tgt) lc_tgt mem_tgt).
  Proof.
    revert_until tmp2.
    pcofix CIH. i.
    pfold. red. ss. subst. splits.
    { (* terminal *)
      i. red in TERMINAL_TGT. ss. des.
      esplits; try refl. red. ss. split.
      - red in TERMINAL_TGT. red. ss.
        destruct stmts_src; ss.
        destruct r0; ss. destruct i; ss.
      - inv LOCAL. congr.
    }

    i. inv STEP_TGT. inv STEP. ss.
    destruct stmts_src; try by inv STATE.
    destruct eu2_tgt as [[stmts2_tgt rmap2_tgt] lc2_tgt mem2_tgt]. ss. subst.
    destruct r0; cycle 1.
    { (* if *)
      inv STATE. inv LOCAL0; inv EVENT.
      inv FRESH. inv H1.
      exploit sim_rmap_sem_expr; try exact FRESH_COND; eauto. i. inv x0.
      exploit sim_local_control; try exact LOCAL; eauto. i. des.
      eexists (RMWExecUnit.mk _ _ _). splits.
      { econs 2; try refl. econs. econs; ss.
        - econs; ss.
        - econs 6; eauto.
      }
      rewrite VAL. condtac; ss.
      - right. eapply CIH; eauto.
        + rewrite List.Forall_app. split; ss.
        + rewrite fold_right_app.
          rewrite <- map_app. ss.
        + congr.
      - right. eapply CIH; eauto.
        + rewrite List.Forall_app. split; ss.
        + rewrite fold_right_app.
          rewrite <- map_app. ss.
        + congr.
    }

    { (* while *)
      inv STATE. inv LOCAL0; inv EVENT.
      eexists (RMWExecUnit.mk _ _ _). splits.
      { econs 2; try refl. econs. econs; ss.
        - econs. ss.
        - econs 1; eauto.
      }
      right. eapply CIH; eauto.
      - inv FRESH. inv H1.
        rewrite List.Forall_app. split; ss.
        repeat (econs; ss).
      - unfold rmw_to_llsc_stmts.
        rewrite map_app.
        rewrite <- fold_right_app. ss.
    }

    inv FRESH.
    rewrite unfold_rmw_to_llsc_stmts in STATE.
    destruct i; ss.
    { (* skip *)
      inv STATE. inv LOCAL0; inv EVENT.
      eexists (RMWExecUnit.mk _ _ _). splits.
      { econs 2; try refl. econs. econs; ss.
        - econs.
        - econs 1; eauto.
      }
      right. eapply CIH; eauto.
    }

    { (* assign *)
      inv STATE. inv LOCAL0; inv EVENT.
      eexists (RMWExecUnit.mk _ _ _). splits.
      { econs 2; try refl. econs. econs; ss.
        - econs. ss.
        - econs 1; ss.
      }
      right. eapply CIH; eauto.
      apply sim_rmap_add; auto.
      eapply sim_rmap_sem_expr; eauto.
      inv H1. ii. ss.
      eapply FRESH; eauto.
      apply IdSet.add_2. ss.
    }

    { (* load *)
      inv STATE. inv LOCAL0; inv EVENT.
      exploit sim_local_read; try exact LOCAL; eauto.
      { eapply sim_rmap_sem_expr; eauto.
        inv H1. ss. ii. eapply FRESH; eauto.
        apply IdSet.add_2. ss.
      }
      i. des.
      eexists (RMWExecUnit.mk _ _ _). splits.
      { econs 2; try refl. econs. econs; ss.
        - econs; eauto.
        - econs 2; eauto.
      }
      right. eapply CIH; eauto.
      - apply sim_rmap_add; ss.
      - rewrite <- EX_FALSE; ss.
    }

    { (* store *)
      inv STATE. inv LOCAL0; inv EVENT; cycle 1.
      { inv STEP. ss. }
      exploit sim_local_fulfill; try exact LOCAL; eauto.
      { eapply sim_rmap_sem_expr; eauto.
        inv H1. ss. ii. eapply FRESH; eauto.
        apply IdSet.union_2. ss.
      }
      { eapply sim_rmap_sem_expr; eauto.
        inv H1. ss. ii. eapply FRESH; eauto.
        apply IdSet.union_3. ss.
      }
      { i. subst. ss. }
      i. des.
      eexists (RMWExecUnit.mk _ _ _). splits.
      { econs 2; try refl. econs. econs; ss.
        - econs; ss.
        - econs 3; eauto.
      }
      right. eapply CIH; eauto.
      - apply sim_rmap_add_r; ss.
        apply IdSet.add_2, IdSet.singleton_2. ss.
      - rewrite <- EXBANK0; ss.
    }

    { (* fadd *)
      inv STATE. inv LOCAL0; inv EVENT.
      esplits; [refl|]. left.
      rename rmap2_tgt into rmap_tgt.
      revert rmap_tgt lc_tgt RMAP LOCAL.
      pcofix CIH_LOOP. i.
      pfold. red. s. splits.
      { i. repeat (red in TERMINAL_TGT; des; ss). }

      (* exclusive load *)
      i. destruct eu2_tgt as [[]].
      inv STEP_TGT. inv STEP. ss. subst.
      inv STATE. inv LOCAL0; inv EVENT.
      esplits; [refl|]. left.
      pfold. red. s. splits.
      { i. repeat (red in TERMINAL_TGT; des; ss). }

      (* exclusive store *)
      i. destruct eu2_tgt as [[]].
      inv STEP_TGT. inv STEP0. ss. subst.
      inv STATE. inv LOCAL0; inv EVENT.

      { (* exclusive store - succeed *)
        clear CIH_LOOP.
        esplits; [refl|]. left.
        pfold. red. s. splits.
        { i. repeat (red in TERMINAL_TGT; des; ss). }

        (* if *)
        i. destruct eu2_tgt as [[]].
        inv STEP_TGT. inv STEP1. ss. subst.
        inv STATE. inv LOCAL0; inv EVENT.
        condtac; ss.
        { exfalso. apply c.
          rewrite RMap.add_o. condtac; try congr.
          inv STEP0. ss.
        }
        clear e X.
        replace local1 with local0 in *; cycle 1.
        { destruct local0, local1.
          inv LC; ss. inv LC2. f_equal.
          rewrite RMap.add_o. condtac; try congr.
          inv STEP0. ss. rewrite ARCH. ss.
          rewrite bot_join; ss.
          destruct view_pre. destruct annot. ss.
          apply View.order.
        }
        clear local1 LC.
        esplits; [refl|].
        left. pfold. red. s. splits.
        { i. repeat (red in TERMINAL_TGT; des; ss). }

        (* fake branch on read value *)
        i. destruct eu2_tgt as [[]].
        inv STEP_TGT. inv STEP1. ss. subst.
        inv STATE. inv LOCAL0; inv EVENT.

        exploit sim_local_read; try exact STEP; eauto.
        { eapply sim_rmap_sem_expr; eauto.
          inv H1. ss. ii. eapply FRESH; eauto.
          apply IdSet.add_2, IdSet.union_2. ss.
        }
        i. des.
        exploit sim_local_fulfill; try exact STEP0; eauto.
        { eapply sim_rmap_sem_expr.
          - eapply sim_rmap_add_r; eauto.
            apply IdSet.add_2, IdSet.singleton_2. ss.
          - inv H1. ss. ii.
            eapply FRESH; eauto.
            apply IdSet.add_2, IdSet.union_2. ss.
        }
        { apply sim_val_sem_op2.
          - rewrite RMap.add_o. condtac; try congr. eauto.
          - eapply sim_rmap_sem_expr.
            + eapply sim_rmap_add_r; eauto.
              apply IdSet.add_2, IdSet.singleton_2. ss.
            + inv H1. ss. ii.
              eapply FRESH; eauto.
              apply IdSet.add_2, IdSet.union_3. ss.
        }
        i. des.
        exploit sim_local_control; try exact LC; eauto.
        { rewrite RMap.add_o. condtac; try congr. clear c X.
          rewrite RMap.add_o. condtac; try congr. clear e X.
          apply RES.
        }
        i. des.

        eexists (RMWExecUnit.mk _ _ _). splits.
        { econs 2; try refl. econs. econs; s.
          - econs; eauto.
          - econs 4; eauto.
          - ss.
        }
        match goal with
        | [|-context[if ?c then ?s else ?s]] =>
            replace (if c then s else s) with s by (condtac; ss); s
        end.
        left. pfold. red. s. splits.
        { i. repeat (red in TERMINAL_TGT; des; ss). }

        (* assign *)
        i. destruct eu2_tgt as [[]].
        inv STEP_TGT. inv STEP1. ss. subst.
        inv STATE. inv LOCAL3; inv EVENT.
        esplits; [refl|].
        right. eapply CIH; eauto.
        - rewrite List.app_nil_r. ss.
        - apply sim_rmap_add.
          + apply sim_rmap_add_r; cycle 1.
            { apply IdSet.add_1. ss. }
            apply sim_rmap_add_r; ss.
            apply IdSet.add_2. apply IdSet.singleton_2. ss.
          + unfold sem_expr.
            rewrite RMap.add_o. condtac; ss.
            rewrite RMap.add_o. condtac; try congr.
        - inv STEP_SRC0. ss.
      }

      { (* exclusive store - fail *)
        inv STEP0. clear CIH EX.
        esplits; try refl. left.
        pfold. red. s. splits.
        { i. repeat (red in TERMINAL_TGT; des; ss). }

        (* if *)
        i. destruct eu2_tgt as [[]].
        inv STEP_TGT. inv STEP0. ss. subst.
        inv STATE. inv LOCAL0; inv EVENT. inv LC. ss.
        repeat rewrite RMap.add_eq; ss.
        replace (join (Local.vcap local) bot) with (Local.vcap local); cycle 1.
        { rewrite bot_join; ss. apply View.order. }
        esplits; try refl. left.
        pfold. red. ss. splits.
        { i. repeat (red in TERMINAL_TGT; des; ss). }

        (* dowhile *)
        i. destruct eu2_tgt as [[]].
        inv STEP_TGT. inv STEP0. ss. subst.
        inv STATE. inv LOCAL0; inv EVENT. ss.
        esplits; [refl|]. right.
        repeat rewrite List.app_nil_r.
        eapply CIH_LOOP.
        - apply sim_rmap_add_r; cycle 1.
          { apply IdSet.add_1. ss. }
          apply sim_rmap_add_r; ss.
          apply IdSet.add_2. apply IdSet.singleton_2. ss.
        - exploit read_sim_local; try exact STEP. i.
          etrans; eauto. etrans; eauto.
          destruct local. ss.
          econs; s; refl.
      }
    }

    { (* barrier *)
      inv STATE. inv LOCAL0; inv EVENT.
      exploit sim_local_dmb; eauto. i. des.
      eexists (RMWExecUnit.mk _ _ _). splits.
      { econs 2; try refl. econs. econs; ss.
        - econs; ss.
        - econs 5; eauto.
      }
      right. eapply CIH; eauto. congr.
    }
  Qed.

  Variant sim_sl (tmp1 tmp2: Id.t):
    forall (sl_src: RMWState.t (A:=View.t (A:=unit)) * Local.t (A:=unit))
           (sl_tgt: State.t (A:=View.t (A:=unit)) * Local.t (A:=unit)), Prop :=
    | sim_sl_intro
        st_src lc_src
        st_tgt lc_tgt
        (TMP: tmp1 <> tmp2)
        (FRESH: List.Forall (fresh (IdSet.add tmp2 (IdSet.singleton tmp1))) st_src.(RMWState.stmts))
        (STMTS: st_tgt.(State.stmts) = rmw_to_llsc_stmts tmp1 tmp2 st_src.(RMWState.stmts))
        (RMAP: sim_rmap (IdSet.add tmp2 (IdSet.singleton tmp1)) st_src.(RMWState.rmap) st_tgt.(State.rmap))
        (LOCAL: sim_local lc_src lc_tgt)
        (EXBANK: lc_src.(Local.exbank) = None):
      sim_sl tmp1 tmp2 (st_src, lc_src) (st_tgt, lc_tgt)
  .

  Variant sim (m_src: RMWMachine.t) (m_tgt: Machine.t): Prop :=
    | sim_machine_intro
        (TPOOL: forall tid, exists tmp1 tmp2,
            opt_rel (sim_sl tmp1 tmp2)
              (IdMap.find tid (RMWMachine.tpool m_src))
              (IdMap.find tid (Machine.tpool m_tgt)))
        (MEMORY: RMWMachine.mem m_src = Machine.mem m_tgt)
  .

  Lemma sim_sl_sim_eu
        tid tmp1 tmp2
        sl_src sl_tgt
        mem_src mem_tgt
        (SIM: sim_sl tmp1 tmp2 sl_src sl_tgt)
        (MEM: mem_src = mem_tgt):
    @sim_eu tid
            (RMWExecUnit.mk (fst sl_src) (snd sl_src) mem_src)
            (ExecUnit.mk (fst sl_tgt) (snd sl_tgt) mem_tgt).
  Proof.
    inv SIM. s.
    destruct st_src, st_tgt. ss.
    eapply rmw_to_llsc_sim_eu; eauto.
  Qed.

  Lemma init_sim
        prog_src prog_tgt
        (COMPILE: rmw_to_llsc_program prog_src prog_tgt):
    sim (RMWMachine.init prog_src) (Machine.init prog_tgt).
  Proof.
    econs; ss. i.
    specialize (COMPILE tid). des.
    exists tmp1, tmp2.
    do 2 rewrite IdMap.map_spec.
    destruct (IdMap.find tid prog_src) eqn:FIND_SRC,
        (IdMap.find tid prog_tgt) eqn:FIND_TGT; ss. des.
    econs. econs; ss; try refl.
  Qed.

  Lemma sim_local_promise
        lc1_src mem1_src
        lc1_tgt mem1_tgt
        loc val ts tid
        lc2_tgt mem2_tgt
        (SIM1: sim_local lc1_src lc1_tgt)
        (MEM1: mem1_src = mem1_tgt)
        (STEP_TGT: Local.promise loc val ts tid lc1_tgt mem1_tgt lc2_tgt mem2_tgt):
    exists lc2_src mem2_src,
      (<<STEP_SRC: Local.promise loc val ts tid lc1_src mem1_src lc2_src mem2_src>>) /\
      (<<SIM2: sim_local lc2_src lc2_tgt>>) /\
      (<<MEM2: mem2_src = mem2_tgt>>).
  Proof.
    destruct lc1_src, lc1_tgt. inv SIM1. ss. subst.
    inv STEP_TGT. ss.
    esplits.
    - econs; eauto.
    - ss.
    - ss.
  Qed.

  Lemma sim_sl_promise_step
        tmp1 tmp2 tid
        st1_src lc1_src mem1_src
        st1_tgt lc1_tgt mem1_tgt
        st2_tgt lc2_tgt mem2_tgt
        (SIM1: sim_sl tmp1 tmp2 (st1_src, lc1_src) (st1_tgt, lc1_tgt))
        (MEM1: mem1_src = mem1_tgt)
        (STEP_TGT: ExecUnit.promise_step tid
                     (ExecUnit.mk st1_tgt lc1_tgt mem1_tgt)
                     (ExecUnit.mk st2_tgt lc2_tgt mem2_tgt)):
    exists st2_src lc2_src mem2_src,
      (<<STEP_SRC: RMWExecUnit.promise_step tid
                     (RMWExecUnit.mk st1_src lc1_src mem1_src)
                     (RMWExecUnit.mk st2_src lc2_src mem2_src)>>) /\
      (<<SIM2: sim_sl tmp1 tmp2 (st2_src, lc2_src) (st2_tgt, lc2_tgt)>>) /\
      (<<MEM2: mem2_src = mem2_tgt>>).
  Proof.
    inv SIM1. inv STEP_TGT. ss. subst.
    exploit sim_local_promise; eauto. i. des. subst.
    esplits.
    - econs; s; eauto.
    - econs; ss. inv STEP_SRC. ss.
    - ss.
  Qed.

  Lemma sim_promise_step
        m1_src m1_tgt m2_tgt
        (SIM1: sim m1_src m1_tgt)
        (STEP_TGT: Machine.step ExecUnit.promise_step m1_tgt m2_tgt):
    exists m2_src,
      (<<STEP_SRC: RMWMachine.step RMWExecUnit.promise_step m1_src m2_src>>) /\
      (<<SIM2: sim m2_src m2_tgt>>).
  Proof.
    destruct m1_src as [tpool1_src mem1_src],
        m1_tgt as [tpool1_tgt mem1_tgt].
    inv SIM1. inv STEP_TGT. ss.
    exploit TPOOL. i. des.
    rewrite FIND in x0. inv x0.
    destruct a as [st1_src lc1_src].
    symmetry in H0. rename H0 into FIND_SRC.
    exploit sim_sl_promise_step; eauto. i. des.
    eexists (RMWMachine.mk _ _).
    esplits.
    - econs; s; eauto.
    - econs; ss. i.
      rewrite TPOOL0.
      do 2 rewrite IdMap.add_spec.
      condtac; eauto.
  Qed.

  Lemma sim_rtc_promise_step
        m1_src m1_tgt m2_tgt
        (SIM1: sim m1_src m1_tgt)
        (STEP_TGT: rtc (Machine.step ExecUnit.promise_step) m1_tgt m2_tgt):
    exists m2_src,
      (<<STEP_SRC: rtc (RMWMachine.step RMWExecUnit.promise_step) m1_src m2_src>>) /\
      (<<SIM2: sim m2_src m2_tgt>>).
  Proof.
    revert m1_src SIM1.
    induction STEP_TGT; i; eauto.
    exploit sim_promise_step; eauto. i. des.
    exploit IHSTEP_TGT; eauto. i. des.
    esplits; [|eauto]. etrans; eauto.
  Qed.

  Lemma sim_eu_exec
        tid eu1_src eu1_tgt eu2_tgt
        (SIM: @sim_eu tid eu1_src eu1_tgt)
        (STEPS_TGT: rtc (ExecUnit.state_step tid) eu1_tgt eu2_tgt)
        (TERMINAL_ST: State.is_terminal eu2_tgt.(ExecUnit.state))
        (TERMINAL_LC: eu2_tgt.(ExecUnit.local).(Local.promises) = bot):
    exists eu2_src,
      (<<STEPS_SRC: rtc (RMWExecUnit.state_step None tid) eu1_src eu2_src>>) /\
      (<<TERMINAL_ST: RMWState.is_terminal eu2_src.(RMWExecUnit.state)>>) /\
      (<<TERMINAL_LC: eu2_src.(RMWExecUnit.local).(Local.promises) = bot>>).
  Proof.
    exploit sim_eu_rtc_state_step; eauto. i. des.
    punfold SIM0. inv SIM0. des.
    exploit H; [econs; ss|]. i. des.
    esplits; try apply TERMINAL_SRC.
    etrans; eauto.
  Qed.

  Lemma sim_state_exec
        m1_src m1_tgt m_tgt
        (SIM: sim m1_src m1_tgt)
        (EXEC_TGT: Machine.state_exec m1_tgt m_tgt)
        (TERMINAL_TGT: Machine.is_terminal m_tgt):
    exists m_src,
      (<<EXEC_SRC: RMWMachine.state_exec m1_src m_src>>) /\
      (<<TERMINAL_TGT: RMWMachine.is_terminal m_src>>) /\
      (<<MEMORY: RMWMachine.mem m_src = Machine.mem m_tgt>>).
  Proof.
    inv SIM. inv EXEC_TGT.
    assert (exists tids,
               (<<IN: forall tid (IN: List.In tid tids),
                   (<<SIM:
                     exists tid1 tid2,
                       opt_rel
                         (sim_sl tid1 tid2)
                         (IdMap.find tid m1_src.(RMWMachine.tpool))
                         (IdMap.find tid m1_tgt.(Machine.tpool))>>) /\
                   (<<EXEC_TGT:
                     opt_rel
                       (fun sl1 sl2 =>
                          rtc (ExecUnit.state_step tid)
                            (ExecUnit.mk (fst sl1) (snd sl1) m1_tgt.(Machine.mem))
                            (ExecUnit.mk (fst sl2) (snd sl2) m1_tgt.(Machine.mem)))
                       (IdMap.find tid m1_tgt.(Machine.tpool))
                       (IdMap.find tid m_tgt.(Machine.tpool))>>)>>) /\
               (<<OUT: forall tid (OUT: ~ List.In tid tids),
                   (<<TERMINAL: forall st_src lc_src
                                  (FIND: IdMap.find tid m1_src.(RMWMachine.tpool) = Some (st_src, lc_src)),
                       (<<TERMINAL_ST: RMWState.is_terminal st_src>>) /\
                       (<<TERMINAL_LC: lc_src.(Local.promises) = bot>>)>>)>>) /\
               (<<NODUP: List.NoDup tids>>)).
    { exists (List.map fst (IdMap.elements m1_src.(RMWMachine.tpool))).
      splits; ss.
      - ii. exfalso. apply OUT.
        setoid_rewrite IdMap.elements_spec in FIND.
        revert FIND. clear.
        generalize (IdMap.elements m1_src.(RMWMachine.tpool)). i.
        induction l; ss.
        destruct a. des_ifs; auto.
      - specialize (IdMap.elements_3w m1_src.(RMWMachine.tpool)). clear.
        generalize (IdMap.elements m1_src.(RMWMachine.tpool)). i.
        induction l; ss.
        inv H. econs; eauto.
        clear - H2. ii.
        induction l; ss. des; eauto.
        destruct a0, a; ss. subst.
        apply H2. left. ss.
    }
    des.
    clear TPOOL TPOOL0.
    revert m1_src m1_tgt IN OUT NODUP MEMORY MEM.

    induction tids; i.
    { exists m1_src. splits.
      - econs; ss. ii.
        destruct (IdMap.find id (RMWMachine.tpool m1_src)); ss.
        econs. refl.
      - econs. i. eapply OUT; eauto.
      - congr.
    }
    exploit IN; [left; refl|]. i. des.
    inv SIM.
    { eapply IHtids; eauto; ii.
      - eapply IN. right. ss.
      - destruct (Id.eq_dec tid a).
        + subst. congr.
        + eapply OUT; eauto. ii. inv H1; ss.
      - inv NODUP. ss.
    }
    destruct a0 as [st1_src lc1_src], b as [st1_tgt lc1_tgt].
    exploit sim_sl_sim_eu; try exact REL; try exact MEMORY. s. intro SIM_EU.
    rewrite <- H in *. inv EXEC_TGT.
    destruct b as [st2_tgt lc2_tgt]. ss.
    inv TERMINAL_TGT. exploit TERMINAL; eauto. i. des.
    exploit sim_eu_exec; try exact REL0; eauto. i. des.
    destruct eu2_src as [st2_src lc2_src mem2_src].
    exploit (RMWExecUnit.rtc_state_step_memory (A:=unit)); try exact STEPS_SRC. s. i. subst.
    destruct m1_src as [tpool1_src mem1_src],
        m1_tgt as [tpool1_tgt mem1_tgt]. ss.
    exploit (IHtids
              (RMWMachine.mk (IdMap.add a (st2_src, lc2_src) tpool1_src) mem1_src)
              (Machine.mk (IdMap.add a (st2_tgt, lc2_tgt) tpool1_tgt) mem1_tgt)); ss.
    { clear IHtids. i.
      repeat rewrite IdMap.add_spec.
      condtac; ss; eauto.
      r in e. subst. inv NODUP. ss.
    }
    { clear IHtids. ii. revert FIND.
      rewrite IdMap.add_spec. condtac; i.
      - r in e. inv FIND. auto.
      - eapply OUT; eauto. ii. des; ss. congr.
    }
    { inv NODUP. ss. }
    i. des. esplits; eauto.
    inv EXEC_SRC. econs; ss.
    ii. specialize (TPOOL id). inv TPOOL.
    - revert H2. rewrite IdMap.add_spec. condtac; ss. i.
      rewrite <- H2. ss.
    - revert H2. rewrite IdMap.add_spec. condtac; ss; i.
      + r in e. subst. inv H2.
        rewrite <- H0. econs. ss. etrans; eauto.
      + rewrite <- H2. econs. ss.
  Qed.

  Theorem rmw_to_llsc
          prog_src prog_tgt m_tgt
          (COMPILE: rmw_to_llsc_program prog_src prog_tgt)
          (EXEC_TGT: Machine.pf_exec prog_tgt m_tgt)
          (TERMINAL_TGT: Machine.is_terminal m_tgt):
    exists m_src,
      (<<EXEC_SRC: RMWMachine.pf_exec prog_src m_src>>) /\
      (<<TERMINAL_TGT: RMWMachine.is_terminal m_src>>) /\
      (<<MEMORY: RMWMachine.mem m_src = Machine.mem m_tgt>>).
  Proof.
    inv EXEC_TGT.
    exploit init_sim; eauto. intro SIM.
    exploit sim_rtc_promise_step; eauto. i. des.
    exploit sim_state_exec; eauto. i. des.
    esplits.
    - econs; eauto. inv TERMINAL_TGT0.
      econs. i. eapply TERMINAL; eauto.
    - ss.
    - ss.
  Qed.
End RMWtoLLSC.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition configure_realm_stage2_spec (rec: Pointer) (adt: RData) : option RData :=
    rely (peq (base rec) buffer_loc);
    when gidx == (buffer (priv adt)) @ (offset rec);
    let gn := (gs (share adt)) @ gidx in
    rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
    rely (ref_accessible gn CPU_ID);
    let comm := g_regs (grec gn) in
    rely (regs_is_int64_dec comm);
    Some adt {priv: (priv adt) {cpu_regs: (cpu_regs (priv adt)) {r_vtcr_el2: (r_vtcr_el2 comm)}
                                                                {r_vttbr_el2: (r_vttbr_el2 comm)}}}.

End Spec.


Set Implicit Arguments.

Require Import Bedrock.Platform.Facade.Facade.

Require Import Bedrock.Platform.Cito.StringMapFacts.
Require Import Coq.Lists.List.
Require Import Bedrock.Platform.Cito.ListFacts4.

Section ADTValue.

  Variable ADTValue : Type.

  Notation RunsTo := (@RunsTo ADTValue).
  Notation State := (@State ADTValue).
  Notation Env := (@Env ADTValue).
  Notation Sca := (@SCA ADTValue).

  Section Safe_coind.

    Variable env : Env.

    Variable R : Stmt -> State -> Prop.

    Hypothesis SeqCase : forall a b st, R (Seq a b) st -> R a st /\ forall st', RunsTo env a st st' -> R b st'.

    Hypothesis IfCase : forall cond t f st, R (If cond t f) st -> (is_true st cond /\ R t st) \/ (is_false st cond /\ R f st).

    Hypothesis WhileCase :
      forall cond body st,
        let loop := While cond body in
        R loop st ->
        (is_true st cond /\ R body st /\ (forall st', RunsTo env body st st' -> R loop st')) \/
        (is_false st cond).

    Hypothesis AssignCase :
      forall x e st,
        R (Facade.Assign x e) st ->
        not_mapsto_adt x st = true /\
        exists w, eval st e = Some (Sca w).

    Hypothesis LabelCase :
      forall x lbl st,
        R (Label x lbl) st ->
        not_mapsto_adt x st = true /\
        exists w, Label2Word env lbl = Some w.

    Hypothesis CallCase :
      forall x f args st,
        R (Call x f args) st ->
        NoDup args /\
        not_mapsto_adt x st = true /\
        exists f_w input,
          eval st f = Some (Sca f_w) /\
          mapM (sel st) args = Some input /\
          ((exists spec,
              Word2Spec env f_w = Some (Axiomatic spec) /\
              PreCond spec input) \/
           (exists spec,
              Word2Spec env f_w = Some (Operational _ spec) /\
              length args = length (ArgVars spec) /\
              let callee_st := make_map (ArgVars spec) input in
              R (Body spec) callee_st /\
              (forall callee_st',
                 RunsTo env (Body spec) callee_st callee_st' ->
                 sel callee_st' (RetVar spec) <> None /\
                 no_adt_leak input (ArgVars spec) (RetVar spec) callee_st'))).

    Hint Constructors Safe.

    Require Import Bedrock.Platform.Cito.GeneralTactics.

    Theorem Safe_coind : forall c st, R c st -> Safe env c st.
      cofix; intros; destruct c.
      - eauto.
      - eapply SeqCase in H; openhyp; eapply SafeSeq; eauto.
      - eapply IfCase in H; openhyp; eauto.
      - eapply WhileCase in H; openhyp; eauto.
      - eapply CallCase in H; openhyp; simpl in *; intuition eauto.
      - eapply LabelCase in H; openhyp; eauto.
      - eapply AssignCase in H; openhyp; eauto.
    Qed.

  End Safe_coind.

End ADTValue.


From RecordUpdate Require Import RecordSet.

From Perennial.program_proof Require Import disk_lib.
From Perennial.program_proof Require Import wal.invariant.

Section goose_lang.
Context `{!heapGS Σ}.
Context `{!walG Σ}.

Implicit Types (γ: wal_names).

Context (P: log_state.t -> iProp Σ).

Hint Unfold slidingM.wf : word.
Hint Unfold slidingM.numMutable : word.

Lemma logIndex_set_mutable f σ pos :
  slidingM.logIndex (set slidingM.mutable f σ) pos = slidingM.logIndex σ pos.
Proof.
  rewrite /slidingM.logIndex //=.
Qed.

Lemma stable_alloc_end γ txns mutable nextDiskEnd_txn_id endpos :
  ( memLog_linv_nextDiskEnd_txn_id γ mutable nextDiskEnd_txn_id ∗
    nextDiskEnd_inv γ txns ∗
    txns_ctx γ txns ∗
    txn_pos γ (length txns - 1) endpos
  )
  ==∗
  (
    memLog_linv_nextDiskEnd_txn_id γ endpos (length txns - 1) ∗
    nextDiskEnd_inv γ txns ∗
    txns_ctx γ txns ∗
    (length txns - 1)%nat [[γ.(stable_txn_ids_name)]]↦ro tt
  ).
Proof.
  iIntros "(H0 & H1 & Htxns_ctx & #Hend)".
  iNamed "H1".
  iNamed "H0".
  iDestruct (txn_pos_valid_general with "Htxns_ctx HnextDiskEnd_txn") as "%HnextDiskEnd_txn".
  eapply is_txn_bound in HnextDiskEnd_txn as HnextDiskEnd_bound.
  iDestruct (map_ctx_agree with "HownStableSet Hstablectx") as %->.
  iCombine "HownStableSet Hstablectx" as "Hstablectx".
  destruct (stable_txns !! (length txns - 1)%nat) eqn:He.
  {
    iDestruct (big_sepM_lookup with "Hstablero") as "#Hstable"; eauto.
    iModIntro.
    iDestruct "Hstablectx" as "[Hstablectx HownStableSet]".
    iFrame "Htxns_ctx Hstable".
    iSplitL "HownStableSet".
    { iExists _. iFrame. iFrame "# %".
      iPureIntro. intros. eapply HnextDiskEnd_max_stable. lia. }
    iExists _. iFrame. iFrame "%".
  }

  iMod (map_alloc_ro with "Hstablectx") as "[Hstablectx #Hstable]"; eauto.
  iDestruct (big_sepM_insert with "[$Hstablero $Hstable]") as "Hstablero"; eauto.
  iModIntro.
  iDestruct "Hstablectx" as "[Hstablectx HownStableSet]".
  iFrame "Htxns_ctx Hstable".
  iSplitL "HownStableSet".
  { iExists _. iFrame. iFrame "# %".
    iPureIntro. intros. rewrite lookup_insert_ne; try lia. eapply HnextDiskEnd_max_stable. lia. }
  iExists _. iFrame.
  iPureIntro. rewrite /stable_sound. intros.
  destruct (decide (txn_id = (length txns - 1)%nat)); subst.
  { eapply is_txn_bound in H2. lia. }
  rewrite lookup_insert_ne in H0; eauto.
Qed.

Theorem wp_sliding__clearMutable_wal l st γ dinit σ :
  {{{ is_wal P l γ dinit ∗ wal_linv_core st γ σ }}}
    sliding__clearMutable (struct.loadF WalogState "memLog" #st)
  {{{ σ', RET #();
    wal_linv_core st γ σ' ∗
    ⌜length σ.(memLog).(slidingM.log) = length σ'.(memLog).(slidingM.log)⌝
  }}}.
Proof.
  iIntros (Φ) "(#Hwal & Hlkinv) HΦ".
  iNamed "Hlkinv".
  iNamed "Hfields".
  iNamed "Hfield_ptsto".
  rewrite -wp_ncfupd.
  iDestruct (is_sliding_wf with "His_memLog") as %Hsliding_wf.
  wp_loadField.
  wp_apply (wp_sliding__clearMutable with "His_memLog").
  iIntros "His_memLog".

  wp_pures. iApply ("HΦ" $! (set memLog (λ _,
    (set slidingM.mutable (λ _ : u64, slidingM.endPos σ.(memLog))
    σ.(memLog))) σ
  )).
  iNamed "HmemLog_linv".
  iNamed "Hlinv_pers".
  iDestruct "HmemStart_txn" as "#HmemStart_txn".
  iDestruct "HmemEnd_txn" as "#HmemEnd_txn".
  iMod (txn_pos_valid_locked with "Hwal HmemEnd_txn Howntxns") as "(%HmemEnd_is_txn & Howntxns)".

  iAssert (txn_pos γ nextDiskEnd_txn_id σ.(memLog).(slidingM.mutable)) as "#HnextDiskEnd_txn0".
  { iNamed "HnextDiskEnd". iFrame "#". }
  iMod (txn_pos_valid_locked with "Hwal HnextDiskEnd_txn0 Howntxns") as "(%HnextDiskEnd_is_txn0 & Howntxns)".

  iDestruct "Hwal" as "[Hinv Hcirc]".
  iInv "Hinv" as (σs) "[Hinner Hp]" "Hclose".
  iDestruct "Hinner" as "(>%Hwf & Hmem & >Htxns_ctx & >γtxns & >HnextDiskEnd_inv & >Hdisk)".
  iDestruct (ghost_var_agree with "Howntxns γtxns") as %->.
  iMod (stable_alloc_end with "[$HnextDiskEnd $HnextDiskEnd_inv $Htxns_ctx $HmemEnd_txn]") as "H".
  iDestruct "H" as "(HnextDiskEnd & HnextDiskEnd_inv & Htxns_ctx & #Hstable)".
  iMod ("Hclose" with "[γtxns Hmem HnextDiskEnd_inv Hdisk Htxns_ctx Hp]").
  { iModIntro.
    iExists _. iFrame. done. }

  iModIntro.
  iDestruct (is_sliding_wf with "His_memLog") as %Hsliding_wf'.
  simpl.
  iSplitL; last by trivial.
  iFrame "# ∗".
  iSplitR "Howntxns HownLoggerPos_linv HownLoggerTxn_linv HnextDiskEnd HownInstallerPosMem_linv HownInstallerTxnMem_linv HownInstalledTxnMem_linv".
  { iExists _; iFrame.
    iPureIntro.
    split_and!; simpl; auto; try word.
    rewrite /slidingM.endPos.
    unfold locked_wf, slidingM.wf in Hlocked_wf.
    word.
  }
  eapply is_txn_bound in HdiskEnd_txn as HdiskEnd_txn_bound.
  eapply is_txn_bound in HnextDiskEnd_is_txn0 as HnextDiskEnd_txn0_bound.
  destruct (decide (int.Z σ.(memLog).(slidingM.mutable) ≤ int.Z (slidingM.endPos σ.(memLog)))).
  2: {
    epose proof (wal_wf_txns_mono_pos Hwf HmemEnd_is_txn HnextDiskEnd_is_txn0). lia.
  }

  iExists installed_txn_id_mem, (length σs.(log_state.txns) - 1)%nat, σs.(log_state.txns), _, _, _, _; simpl.
  iFrame "Howntxns HownLoggerPos_linv HownLoggerTxn_linv".
  iFrame "HmemStart_txn HmemEnd_txn".
  iFrame "HownInstallerPosMem_linv HownInstallerTxnMem_linv HownInstalledTxnMem_linv".
  iFrame "% HinstalledTxn_lb".
  iSplit.
  2: {
    iNamed "HnextDiskEnd". iExists _. iFrame. iFrame "#". iFrame "%".
  }
  iSplit.
  { iPureIntro. lia. }
  iSplit.
  { iPureIntro. lia. }
  iSplit.
  2: {
    iPureIntro.
    rewrite /slidingM.endPos.
    word.
  }
  iPureIntro.
  rewrite /memLog_linv_txns !logIndex_set_mutable /slidingM.endPos
    /mwrb.logend /slidingM.logIndex /=.
  rewrite /memLog_linv_txns /mwrb.logend /slidingM.logIndex in Htxns.
  replace (S (_ - 1))%nat with (length σs.(log_state.txns)); last by lia.
  eapply (is_memLog_boundaries_move _ _ _ mwrb_us) in Htxns;
    last by reflexivity.
  simpl in Htxns.
  replace (int.nat (word.add _ _) - int.nat _)%nat
    with (length σ.(memLog).(slidingM.log)) by word.
  assumption.
Qed.

Theorem wp_endGroupTxn st γ :
  {{{ wal_linv st γ }}}
    WalogState__endGroupTxn #st
  {{{ RET #(); wal_linv st γ }}}.
Proof.
  iIntros (Φ) "Hlkinv HΦ".
  iNamed "Hlkinv".
  iNamed "Hfields".
  iNamed "Hfield_ptsto".
  iNamed "His_memLog".
  iNamed "Hinv".
  iNamed "needFlush".
  wp_call.
  wp_loadField.
  wp_storeField.

  iApply "HΦ".
  iModIntro.
  iExists _.
  iFrame.
  iExists _.
  iFrame (Hlocked_wf Hwf) "∗".
  iExists _, _.
  iFrame "∗ #".
  iExists _.
  iFrame.
Qed.

Lemma is_txn_mid σ (a b c : nat) pos :
  wal_wf σ ->
  is_txn σ.(log_state.txns) a pos ->
  is_txn σ.(log_state.txns) c pos ->
  a ≤ b ≤ c ->
  is_txn σ.(log_state.txns) b pos.
Proof.
  rewrite /is_txn /wal_wf; intros Hwf Ha Hc Hle.
  destruct Hwf as [_ [Hwf _]].
  destruct (decide (a < b)).
  2: { assert (a = b) by lia; subst; eauto. }
  destruct (decide (b < c)).
  2: { assert (b = c) by lia; subst; eauto. }
  assert (is_Some (σ.(log_state.txns) !! b)).
  { eapply lookup_lt_is_Some_2. etransitivity.
    2: {
      eapply lookup_lt_is_Some_1.
      eapply fmap_is_Some. eauto.
    }
    lia.
  }

  destruct H as [tb Hb'].
  assert (fst <$> σ.(log_state.txns) !! b = Some (fst tb)) as Hb.
  { rewrite Hb'. reflexivity. }

  rewrite -list_lookup_fmap in Ha.
  rewrite -list_lookup_fmap in Hb.
  rewrite -list_lookup_fmap in Hc.
  rewrite -list_lookup_fmap.

  eapply Hwf in Ha as Hab'.
  1: eapply Hab' in Hb as Hab. 2: lia.
  eapply Hwf in Hb as Hbc'.
  1: eapply Hbc' in Hc as Hbc. 2: lia.
  rewrite Hb. f_equal. word.
Qed.

Lemma subslice_stable_nils γ σ (txn_id txn_id' : nat) pos :
  wal_wf σ ->
  txn_id ≤ txn_id' ->
  is_txn σ.(log_state.txns) txn_id pos ->
  is_txn σ.(log_state.txns) txn_id' pos ->
  ( nextDiskEnd_inv γ σ.(log_state.txns) ∗
    txn_id [[γ.(stable_txn_ids_name)]]↦ro () ) -∗
  ⌜Forall (λ x, snd x = nil) (subslice (S txn_id) (S txn_id') σ.(log_state.txns))⌝.
Proof.
  intros.
  iIntros "[Hinv Hstable]".
  iNamed "Hinv".
  iDestruct (map_ro_valid with "Hstablectx Hstable") as "%Hvalid".
  iPureIntro.
  apply Forall_lookup_2; intros.
  apply subslice_lookup_some in H3 as H3'.
  assert (snd <$> σ.(log_state.txns) !! (S txn_id + i)%nat = Some x.2).
  { rewrite H3'. eauto. }
  erewrite HafterNextDiskEnd in H4; simplify_eq/=; eauto.
  { lia. }
  eapply is_txn_mid; [ done | apply H1 | apply H2 |].
  apply subslice_lookup_bound' in H3.
  lia.
Qed.

Lemma subslice_stable_nils2 γ σ (txn_id txn_id' : nat) pos :
  wal_wf σ ->
  is_txn σ.(log_state.txns) txn_id pos ->
  is_txn σ.(log_state.txns) txn_id' pos ->
  ( nextDiskEnd_inv γ σ.(log_state.txns) ∗
    txn_id [[γ.(stable_txn_ids_name)]]↦ro () ) -∗
  ⌜Forall (λ x, snd x = nil) (subslice (S txn_id) (S txn_id') σ.(log_state.txns))⌝.
Proof.
  intros.
  iIntros "[Hinv Hstable]".
  destruct (decide (txn_id ≤ txn_id')).
  { iApply subslice_stable_nils; eauto. }

  iPureIntro.
  rewrite /subslice.
  rewrite drop_ge; eauto.
  etransitivity; first by apply firstn_le_length.
  lia.
Qed.

Lemma stable_sound_alloc txns stable_txns (txn_id txn_id' : nat) (pos : u64) :
  stable_txns !! txn_id = Some () ->
  txn_id ≤ txn_id' ->
  is_txn txns txn_id pos ->
  is_txn txns txn_id' pos ->
  stable_sound txns stable_txns ->
  stable_sound txns (<[txn_id':=()]> stable_txns).
Proof.
  rewrite /stable_sound.
  intros.

  destruct (decide (txn_id' = txn_id0)).
  { subst.
    eapply (H3 txn_id txn_id'0 pos); try eassumption.
    1: lia.
    pose proof (is_txn_pos_unique _ _ _ _ H2 H6); subst.
    eauto.
  }
  eapply H3; try eassumption.
  rewrite lookup_insert_ne in H5; eauto.
Qed.

Lemma stable_sound_nils σ stable_txns txn_id txn_id' pos :
  wal_wf σ ->
  stable_txns !! txn_id = Some () ->
  is_txn σ.(log_state.txns) txn_id pos ->
  is_txn σ.(log_state.txns) txn_id' pos ->
  stable_sound σ.(log_state.txns) stable_txns ->
  Forall (λ x, x.2 = []) (subslice (S txn_id) (S txn_id') σ.(log_state.txns)).
Proof.
  intros.
  apply Forall_lookup_2; intros.
  apply subslice_lookup_some in H4 as H4'.
  assert (snd <$> σ.(log_state.txns) !! (S txn_id + i)%nat = Some x.2).
  { rewrite H4'. eauto. }
  erewrite H3 in H5; simplify_eq/=; eauto.
  { lia. }
  eapply is_txn_mid; [ done | apply H1 | apply H2 | ].
  eapply subslice_lookup_bound' in H4 as Hbound.
  lia.
Qed.

Theorem stable_txn_id_advance γ mutable txn_id txn_id' pos nextDiskEnd_txn_id σ :
  wal_wf σ ->
  is_txn σ.(log_state.txns) txn_id pos ->
  is_txn σ.(log_state.txns) txn_id' pos ->
  txn_id ≤ txn_id' ->
  memLog_linv_nextDiskEnd_txn_id γ mutable nextDiskEnd_txn_id -∗
  nextDiskEnd_inv γ σ.(log_state.txns) -∗
  txn_id [[γ.(stable_txn_ids_name)]]↦ro () -∗
  txns_ctx γ σ.(log_state.txns)
  ==∗ (
    txn_id' [[γ.(stable_txn_ids_name)]]↦ro () ∗
    nextDiskEnd_inv γ σ.(log_state.txns) ∗
    txns_ctx γ σ.(log_state.txns) ∗
    ∃ nextDiskEnd_txn_id',
      memLog_linv_nextDiskEnd_txn_id γ mutable nextDiskEnd_txn_id' ∗
      ⌜nextDiskEnd_txn_id ≤ nextDiskEnd_txn_id' < length σ.(log_state.txns)⌝ ∗
      ⌜Forall (λ x, x.2 = []) (subslice (S nextDiskEnd_txn_id) (S nextDiskEnd_txn_id') σ.(log_state.txns))⌝
  ).
Proof.
  clear P.

  iIntros (Hwf Histxn Histxn' Hle) "H0 H1 #Hstable Htxns_ctx".
  iNamed "H0".
  iNamed "H1".
  iDestruct (map_ctx_agree with "HownStableSet Hstablectx") as "%Heq". subst.
  iDestruct (map_valid with "HownStableSet Hstable") as "%Hstable".

  iDestruct (map_valid with "Hstablectx HnextDiskEnd_stable") as "%HnextDiskEnd_stable".
  iDestruct (txn_pos_valid_general with "Htxns_ctx HnextDiskEnd_txn") as "%HnextDiskEnd_txn".

  destruct (stable_txns0 !! txn_id') eqn:He.
  {
    iDestruct (big_sepM_lookup with "Hstablero") as "#Hstable'"; eauto.
    iModIntro.
    iFrame "Hstable' Htxns_ctx".
    iSplitL "Hstablectx Hstablero".
    { iExists _. iFrame. iFrame "%". }
    iExists nextDiskEnd_txn_id.
    iSplitL "HownStableSet".
    { iExists _. iFrame. iFrame "#". iFrame "%". }
    rewrite subslice_zero_length.
    eapply is_txn_bound in HnextDiskEnd_txn.
    iPureIntro. intuition eauto; lia.
  }

  iCombine "HownStableSet Hstablectx" as "Hctx".
  iMod (map_alloc_ro with "Hctx") as "[Hctx #Hstable']"; eauto.
  iDestruct (big_sepM_insert with "[$Hstablero Hstable']") as "Hstablero"; eauto.
  iFrame "Hstable'".

  iModIntro.
  iDestruct "Hctx" as "[HownStableSet Hstablectx]".
  iSplitL "Hstablectx Hstablero".
  { iExists _. iFrame "Hstablectx". iFrame.
    iPureIntro. eapply stable_sound_alloc. 1: apply Hstable. all: eauto. }

  destruct (decide (txn_id' ≤ nextDiskEnd_txn_id)).
  {
    iFrame "Htxns_ctx".
    iExists nextDiskEnd_txn_id.
    iSplitL "HownStableSet".
    { iExists _. iFrame. iFrame "#".
      iPureIntro. intros.
      destruct (decide (txn_id0 = txn_id')); try lia.
      rewrite lookup_insert_ne; eauto. }
    iPureIntro.
    rewrite subslice_zero_length.
    eapply is_txn_bound in HnextDiskEnd_txn.
    intuition eauto; lia.
  }

  destruct (decide (nextDiskEnd_txn_id < txn_id)).
  {
    rewrite HnextDiskEnd_max_stable in Hstable; try lia. congruence.
  }

  assert (is_txn σ.(log_state.txns) nextDiskEnd_txn_id pos) as Hnextpos.
  {
    eapply (is_txn_mid _ txn_id _ txn_id'); eauto.
    word.
  }

  pose proof (is_txn_pos_unique _ _ _ _ HnextDiskEnd_txn Hnextpos); subst.

  iDestruct (txns_ctx_txn_pos _ _ txn_id' with "Htxns_ctx") as "#Htxn_id'_pos"; eauto.
  iFrame.
  iExists txn_id'.
  iSplit.
  { iExists _. iFrame. iFrame "Hstable'". iFrame "Htxn_id'_pos".
    iPureIntro. intros. rewrite lookup_insert_ne; last by lia.
    eapply HnextDiskEnd_max_stable. lia. }
  eapply is_txn_bound in Histxn' as Histxn'_bound.
  iPureIntro. intuition try lia.
  eapply stable_sound_nils; eauto.
Qed.

End goose_lang.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import CtxtSwitchAux.Spec.
Require Import AbsAccessor.Spec.
Require Import CtxtSwitchAux.Layer.
Require Import CtxtSwitch.Code.save_realm_state.

Require Import CtxtSwitch.LowSpecs.save_realm_state.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _save_sysreg_state ↦ gensem save_sysreg_state_spec
      ⊕ _sysreg_read ↦ gensem sysreg_read_spec
      ⊕ _set_rec_pc ↦ gensem set_rec_pc_spec
      ⊕ _set_rec_pstate ↦ gensem set_rec_pstate_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_save_sysreg_state: block.
    Hypothesis h_save_sysreg_state_s : Genv.find_symbol ge _save_sysreg_state = Some b_save_sysreg_state.
    Hypothesis h_save_sysreg_state_p : Genv.find_funct_ptr ge b_save_sysreg_state
                                       = Some (External (EF_external _save_sysreg_state
                                                        (signature_of_type (Tcons Tptr Tnil) tvoid cc_default))
                                              (Tcons Tptr Tnil) tvoid cc_default).
    Local Opaque save_sysreg_state_spec.

    Variable b_sysreg_read: block.
    Hypothesis h_sysreg_read_s : Genv.find_symbol ge _sysreg_read = Some b_sysreg_read.
    Hypothesis h_sysreg_read_p : Genv.find_funct_ptr ge b_sysreg_read
                                 = Some (External (EF_external _sysreg_read
                                                  (signature_of_type (Tcons tuint Tnil) tulong cc_default))
                                        (Tcons tuint Tnil) tulong cc_default).
    Local Opaque sysreg_read_spec.

    Variable b_set_rec_pc: block.
    Hypothesis h_set_rec_pc_s : Genv.find_symbol ge _set_rec_pc = Some b_set_rec_pc.
    Hypothesis h_set_rec_pc_p : Genv.find_funct_ptr ge b_set_rec_pc
                                = Some (External (EF_external _set_rec_pc
                                                 (signature_of_type (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default))
                                       (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default).
    Local Opaque set_rec_pc_spec.

    Variable b_set_rec_pstate: block.
    Hypothesis h_set_rec_pstate_s : Genv.find_symbol ge _set_rec_pstate = Some b_set_rec_pstate.
    Hypothesis h_set_rec_pstate_p : Genv.find_funct_ptr ge b_set_rec_pstate
                                    = Some (External (EF_external _set_rec_pstate
                                                     (signature_of_type (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default))
                                           (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default).
    Local Opaque set_rec_pstate_spec.

    Lemma save_realm_state_body_correct:
      forall m d d' env le rec_base rec_offset
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTrec: PTree.get _rec le = Some (Vptr rec_base (Int.repr rec_offset)))
             (Hspec: save_realm_state_spec0 (rec_base, rec_offset) d = Some d'),
           exists le', (exec_stmt ge env le ((m, d): mem) save_realm_state_body E0 le' (m, d') Out_normal).
    Proof.
      solve_code_proof Hspec save_realm_state_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.