(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

Require Import floating_point.GenFloat.

(* Why3 goal *)
Definition single : Type.
exact (t 24 128).
Defined.

Global Instance single_WhyType : WhyType single.
Proof.
apply t_WhyType.
Qed.


Set Implicit Arguments.
From TLC Require Import LibLogic LibReflect.
From TLC Require LibListZ.
Require Import CakeSem.Namespace.
Require Import CakeSem.Utils.
Require Import CakeSem.CakeAST.
Require Import CakeSem.SemanticsAux.
Require Import CakeSem.ffi.FFI.
Require Import String.
Require Import List.
Import ListNotations.
Require Import ZArith.
Require String.

Open Scope string.
Open Scope Z_scope.
Open Scope list_scope.

(*--------------------------*)
(** Notes *)

(* LATER: we could use implicit types to avoid type annotations for arguments of constructors throughout the files.
   This would reduce the clutter. However, it requires renaming a bunch of variables, and would make it harder
   to keep in sync with the cakeML semantics, so let's not do it now. *)

(*--------------------------*)

(** If the flag [doTypeChecks] is True, then the semantics performs a few type checks like the CakeML semantics does.
    If the source code does type-check independently, then the flag may be set to False without altering the semantics. *)

Parameter doTypeChecks : bool.

Definition TypeCheck (P:Prop) :=
  if doTypeChecks then P else True.

(* BACKPORT: these definitions should be used throughout (with result in bool) *)

Definition UniquePatBindings (p:pat) : Prop :=
  LibList.noduplicates (pat_bindings p).

Definition UniqueRecIdent (funs : list (varN * varN * exp)) : Prop :=
  LibList.noduplicates (List.map (fun '(f,_,_) => f) funs).

Definition UniqueCtorsInDef (td : list tvarN * typeN * list (conN * list ast_t)) : Prop :=
  let '(tvs,tn,condefs) := td in
  LibList.noduplicates (List.map (fun '(n,_) => n) condefs).

Definition UniqueCtorsInDefs (tds : typeDef) : Prop :=
  LibList.Forall UniqueCtorsInDef tds.

(*--------------------------*)

(* ********************************************************************** *)
(** * Primitive operations *)

(* ---------------------------------------------------------------------- *)
(** ** Equality *)

(** [appEq v1 v2 P] asserts that the values [v1] and [v2] are comparable
    and that the proposition [P] characterizes whether they are equal.

    [appEqList vs1 vs2 P] is similar, and requires the list to be of the
    same lengths. *)

(** BACKPORT: it is very strange to specify that all closures are equal,
    this will certainly cause end-user bugs eventually. *)

Inductive appEq : val -> val -> Prop -> Prop :=

  | appEq_lit : forall l1 l2,
      TypeCheck (lit_same_type l1 l2) ->
      appEq (Litv l1) (Litv l2) (l1 = l2)

  | appEq_loc : forall l1 l2,
      appEq (Loc l1) (Loc l2) (l1 = l2)

  | appEq_closure : forall v1 v2,
      is_closure v1 ->
      is_closure v2 ->
      appEq v1 v2 True

  | appEq_conv_eq : forall cn vs1 vs2 P,
      length vs1 = length vs2 ->
      appEqList vs1 vs2 P ->
      appEq (Conv cn vs1) (Conv cn vs2) P

  | appEq_conv_neq : forall cn1 cn2 vs1 vs2,
      cn1 <> cn2 ->
      TypeCheck (ctor_same_type cn1 cn2) ->
      appEq (Conv cn1 vs1) (Conv cn2 vs2) False

  | appEq_vector_eq_length : forall vs1 vs2 P,
      length vs1 = length vs2 ->
      appEqList vs1 vs2 P ->
      appEq (Vectorv vs1) (Vectorv vs2) P

  | appEq_vector_neq_length : forall vs1 vs2,
      length vs1 <> length vs2 ->
      appEq (Vectorv vs1) (Vectorv vs2) False

with appEqList : list val -> list val -> Prop -> Prop :=

  | appEqList_nil :
      appEqList [] [] True

  | appEqList_cons : forall v1 v2 vs1 vs2 P Ps,
      appEq v1 v2 P ->
      appEqList vs1 vs2 Ps ->
      appEqList (v1::vs1) (v2::vs2) (P /\ Ps).

(* ---------------------------------------------------------------------- *)
(** ** Primitive operations *)

(** [appr s ffi op vs s' ffi' v'] asserts that the evaluation of [op] on the arguments [vs]
    produces output [v], and updates the states accordingly.
    This is an inductive version of do_app.

    DISCLAIMER: currently covers only a subset of primitive functions. *)

Inductive appR (FFI : Type) (s : store val) (t : ffi_state FFI) : op -> list val -> store val -> ffi_state FFI -> val -> Prop :=

  | appR_Opn : forall op (a b : int),
      ((op = Divide \/ op = Modulo) -> b <> 0) ->
      appR s t (Opn op) [Litv (IntLit a); Litv (IntLit b)] s t (Litv (IntLit (opn_lookup op a b)))

  | appR_Opb : forall op (a b : int),
      appR s t (Opb op) [Litv (IntLit a); Litv (IntLit b)] s t (Propv (opb_lookup_Prop op a b))

  | appR_Equality : forall (v1 v2 : val) (P:Prop),
      appEq v1 v2 P ->
      appR s t Equality [v1; v2] s t (Propv P)

  | appR_Opassign : forall s' v lnum,
      s' = store_assign_nocheck lnum (Refv v) s ->
      appR s t Opassign [Loc lnum; v] s' t ConvUnit

  | appR_Opref : forall s' v n,
      (s',n) = store_alloc (Refv v) s ->
      appR s t Opref [v] s' t (Loc n)

  | appR_Opderef : forall v n,
      store_lookup n s = Some (Refv v) ->
      appR s t Opderef [Loc n] s t v

  | appR_Aalloc : forall n v s' lnum n',
      n >= 0 ->
      n = Z.of_nat n' ->
      (s',lnum) = store_alloc (Varray (List_replicate n' v)) s ->
      appR s t Aalloc [Litv (IntLit n); v] s' t (Loc lnum)

  | appR_Alength : forall n ws,
      store_lookup n s = Some (Varray ws) ->
      appR s t Alength [Loc n] s t (Litv (IntLit (Z.of_nat (List.length ws))))

  | appR_Asub : forall lnum i vs v i',
      store_lookup lnum s = Some (Varray vs) ->
      (0 <= i < Zlength vs) ->
      i = Z.of_nat i' ->
      v = LibList.nth i' vs ->
      appR s t Asub [Loc lnum; Litv (IntLit i)] s t v

  | appR_Aupdate : forall lnum i n (vs:list val) s' v i',
      store_lookup n s = Some (Varray vs) ->
      (0 <= i < Zlength vs)%Z ->
      i = Z.of_nat i' ->
      s' = store_assign_nocheck lnum (Varray (LibList.update i' v vs)) s ->
      appR s t Aupdate [Loc lnum; Litv (IntLit i); v] s' t ConvUnit.

(** Alternative definitions using LibListZ to manipulate lists using integer indices directly

  | appR_Aalloc' : forall n v s' lnum,
      n >= 0 ->
      (s',lnum) = store_alloc (Varray (ListZ_replicate n v)) s ->
      appR s t Aalloc [Litv (IntLit n); v] s' t (Loc lnum)

  | appR_Alength' : forall n ws,
      store_lookup n s = Some (Varray ws) ->
      appR s t Alength [Loc n] s t (Litv (IntLit (LibListZ.length ws)))

  | appR_Asub' : forall lnum i vs,
      store_lookup lnum s = Some (Varray vs) ->
      (0 <= i < List.length vs)%Z ->
      appR s t Asub [Loc lnum; Litv (IntLit i)] s t (LibContainer.read vs i)

  | appR_Aupdate' : forall lnum i n vs s' v,
      store_lookup n s = Some (Varray vs) ->
      (0 <= i < List.length vs)%Z ->
      s' = store_assign_nocheck lnum (Varray (LibContainer.update vs i v)) s ->
      appR s t Aupdate [Loc lnum; Litv (IntLit i); v] s' t ConvUnit.
*)

(* ---------------------------------------------------------------------- *)
(** ** Regular function calls *)

(** [opapp v env n e] asserts that [v] is a closure or recursive closure
    whose argument is named [n] and whose body is [e], to be executed in
    an environment [env] that includes the recursive bindings (if any).
    This is an inductive version of [do_opapp] *)

Inductive opapp : val -> sem_env val -> varN -> exp -> Prop :=

  | opapp_Closure : forall (env : sem_env val) (n : varN) (e : exp),
      opapp (Closure env n e) env n e

  | opapp_Recclosure : forall (env env': sem_env val) (funs : list (varN * varN * exp)) (nfun n : varN) (e : exp),
      TypeCheck (UniqueRecIdent funs) ->
      env' = update_sev env (build_rec_env funs env (sev env)) ->
      find_recfun nfun funs = Some (n,e) ->
      opapp (Recclosure env funs nfun) env' n e.

(* ********************************************************************** *)
(** * Pattern matching *)

(* ---------------------------------------------------------------------- *)
(** ** Matching against one pattern *)

(** [pmatchR cenv st p v r] matches a value [v] against a pattern [p] and relates it
    to a result [r] which is either [No_match] or [Match env_v] for some set of bindings [env_v].

    Note: for tuples and constructors, the assumption [length vs = length ps] is redundant
    with [patchlistR ... ps vs]  *)

Inductive pmatchR (cenv : env_ctor) : store val -> pat -> val -> match_result (alist varN val) -> Prop :=

  | pmatchR_Pany : forall (sto : store val) (v : val),
      pmatchR cenv sto Pany v (Match [])

  | pmatchR_Pvar : forall (sto : store val) (v : val) (x : varN),
      pmatchR cenv sto (Pvar x) v (Match [(x,v)])

  | pmatchR_Plit_yes : forall (sto : store val) (l : lit),
      pmatchR cenv sto (Plit l) (Litv l) (Match [])

  | pmatchR_Plit_no : forall (sto : store val) (l1 l2 : lit),
      TypeCheck (lit_same_type l1 l2) ->
      l1 <> l2 ->
      pmatchR cenv sto (Plit l1) (Litv l2) No_match

  | pmatchR_Ptuple : forall (sto : store val) (ps : list pat) (vs : list val) m,
      pmatchListR cenv sto ps vs m ->
      pmatchR cenv sto (Pcon None ps) (Conv None vs) m

  | pmatchR_PconYes : forall (sto : store val) (n : ident modN conN) (nstamp : stamp) (ps : list pat) (vs : list val) m,
      nsLookup n cenv = Some (length ps, nstamp) ->
      pmatchListR cenv sto ps vs m ->
      pmatchR cenv sto (Pcon (Some n) ps) (Conv (Some nstamp) vs) m

  | pmatchR_PconNo : forall (sto : store val) (n : ident modN conN) (nstamp1 nstamp2 : stamp) (ps : list pat) (vs : list val),
      nsLookup n cenv = Some (length ps, nstamp2) ->
      TypeCheck (stamp_same_type nstamp1 nstamp2) ->
      nstamp1 <> nstamp2 ->
      pmatchR cenv sto (Pcon (Some n) ps) (Conv (Some nstamp1) vs) No_match

  | pmatchR_Pref : forall (sto : store val) (lnum : nat) (p : pat) (v : val) m,
     store_lookup lnum sto = Some (Refv v) ->
     pmatchR cenv sto p v m ->
     pmatchR cenv sto (Pref p) (Loc lnum) m

  | pmatchR_Ptannot : forall (sto : store val) (p : pat) (v : val) (t : ast_t) m,
      pmatchR cenv sto p v m ->
      pmatchR cenv sto (Ptannot p t) v m

(** [pmatchListR cenv st ps vs r] matches a list of values [vs] against a list of patterns [ps],
    and relates it to a result [r] which is either [No_match] or [Match env_v] for some set of
    bindings [env_v].
    The predicate can only hold when [ps] and [vs] have the same length. *)

with pmatchListR (cenv: env_ctor) : store val -> list pat -> list val -> match_result (alist varN val) -> Prop :=

  | pmatchListR_nil : forall (sto : store val),
      pmatchListR cenv sto [] [] (Match [])

  | pmatchListR_cons_yes : forall (sto : store val) (p : pat) (ps : list pat) (v : val) (vs : list val) env_v1 env_v2,
      pmatchR cenv sto p v (Match env_v1) ->
      pmatchListR cenv sto ps vs (Match env_v2) ->
      pmatchListR cenv sto (p::ps) (v::vs) (Match (env_v1 ++ env_v2))
      (* Note: the order of nsAppend should be irrelevant because pattern variables are unique. *)

  | pmatchListR_cons_no : forall (sto : store val) (p : pat) (ps : list pat) (v : val) (vs : list val) m,
      pmatchR cenv sto p v No_match ->
      pmatchListR cenv sto ps vs m ->
      pmatchListR cenv sto (p::ps) (v::vs) No_match.

(* ---------------------------------------------------------------------- *)
(** ** Matching against a list of clauses *)

(** [matR st env v pes matchres] matches the value [v] against the list of clauses [pes],
    and returns [None] if no pattern matches, or [Some (env_v,e_clause)] if the first clause that
    applies has body [e_clause] and instantiate the pattern variables according to [env_v].
    This is an inductive version of [evaluate_match] from the Lem semantics, up to the fact that
    it does not perform the recursive call to evaluate directly, but instead returns the arguments
    to be provided for that call. *)
(* Inductive matR : (A : Type) (st : state A) (env : sem_env val): val -> pat * exp -> option (alist varN val * exp) := *)
(* | matR_yes : forall (v : val) (p : pat) (e : exp) env_v, *)
(*     pmatchR (sec env) (refs st) p v (Match env_v) -> *)
(*     matR st env v (p,e) (Some (env_v,e)) *)

(* | matR_no : forall (v : val) (p : pat) (e : exp), *)
(*     pmatchR (sec env) (refs st) p v No_match -> *)
(*     matR st env v (p,e) None *)

(* with matRList (A : Type) (st : state A) (env : sem_env val) : val -> list (pat * exp) -> option (alist varN val * exp) -> Prop := *)

(*    | matRList_nil : forall (v : val), *)
(*       matRList st env v [] None *)

(*    | matRList_consYes : forall (v : val) (p : pat) (e : exp) (pes' : list (pat * exp)) env_v, *)
(*        TypeCheck (UniquePatBindings p) -> *)
(*        pmatchR (sec env) (refs st) p v (Match env) -> *)
(*        matRList st env v ((p,e)::pes') (Some (env_v,e)). *)

 Inductive matR (A : Type) (st : state A) (env : sem_env val) : val -> list (pat * exp) -> option (alist varN val * exp) -> Prop :=
 | matR_nil : forall (v : val),
     matR st env v [] None

 | matR_consFail : forall (v : val) (p : pat) (e : exp) (pes' : list (pat * exp)),
       TypeCheck (UniquePatBindings p) ->
       pmatchR (sec env) (refs st) p v No_match ->
       matR st env v (pes') None ->
       matR st env v ((p,e)::pes') None

 | matR_consSucc : forall (v : val) (p : pat) (e e' : exp) (pes' : list (pat * exp)) env_v,
     TypeCheck (UniquePatBindings p) ->
     (pmatchR (sec env) (refs st) p v (Match env_v) /\ e = e') \/ matR st env v pes' (Some (env_v,e')) ->
     matR st env v ((p,e)::pes') (Some (env_v,e')).

(* ********************************************************************** *)
(** * Evaluation *)

(* ---------------------------------------------------------------------- *)
(** ** Evaluation of expressions *)

(** [expR st env e (st', Rval v)] asserts that, in environment [env], the expression [e] evaluates to [v],
    and updates the state from [st] to [st']. *)

Inductive expR (A : Type) (st : state A) (env : sem_env val) : exp -> (state A) * result val val -> Prop :=

  | expR_ELit : forall (l : lit),
      expR st env (ELit l) (st, Rval (Litv l))

  | expR_ECon : forall (st' : state A) (es : list exp) (vs : list val) (o : constr_id) (os : option stamp),
      TypeCheck (con_check (sec env) o (length es)) ->
      expListRevR st env es (st', Rval vs) ->
      con_build (sec env) o os ->
      expR st env (ECon o es) (st', Rval (Conv os vs))

  | expR_EVar : forall (v : val) (i : ident modN varN),
      nsLookup i (sev env) = Some v ->
      expR st env (EVar i) (st, Rval v)

  | expR_EFun : forall (e : exp) (x : varN),
      expR st env (EFun x e) (st, Rval (Closure env x e))

  | expR_EAppFunction  : forall (st': state A) (env' envclos : sem_env val) (ebody : exp) (es : list exp) (n : varN) v vclos res,
      expListRevR st env es (st', Rval [vclos; v]) ->
      opapp vclos envclos n ebody ->
      env' = update_sev envclos (nsBind n v (sev envclos)) ->
      expR st' env' ebody res ->
      expR st env (EApp Opapp es) res

  | expR_EAppPrimitive : forall (st' st'' : state A) (s' : store val) (ffi' : ffi_state A) (o : op) (es : list exp) (v : val) (vs : list val),
      o <> Opapp -> (* redundant with [appR] but perhaps convenient in proofs *)
      expListRevR st env es (st', Rval vs) ->
      appR (refs st') (ffi st') o vs s' ffi' v ->
      st'' = state_update_refs_and_ffi st' s' ffi' ->
      expR st env (EApp o es) (st'', Rval v)

  | expR_ELogFst : forall (st' : state A) (op : lop) (e1 e2 : exp) (v1: val),
      expR st env e1 (st', Rval v1) ->
      (match op with
       | And => v1 = Boolv false
       | Or => v1 = Boolv true
       end) ->
      expR st env (ELog op e1 e2) (st', Rval v1)

  | expR_ELogSnd : forall (st' : state A) (op : lop) (e1 e2 : exp) (v1: val) res,
      expR st env e1 (st', Rval v1) ->
      (match op with
       | And => v1 = Boolv true
       | Or => v1 = Boolv false
       end) ->
      expR st' env e2 res ->
      expR st env (ELog op e1 e2) res

  | expR_EIf : forall (st' : state A) (e1 e2 e3 : exp) v1 res,
      expR st env e1 (st', Rval v1) ->
      (v1 = Boolv true  -> expR st' env e2 res) ->
      (v1 = Boolv false -> expR st' env e3 res) ->
      expR st env (EIf e1 e2 e3) res

  | expR_EMatVal : forall (env' : sem_env val) (e : exp) (pes : list (pat * exp)) (v : val) st' env_v e_clause res,
      expR st env e (st', Rval v) ->
      matR st env v pes (Some (env_v, e_clause)) ->
      env' = update_sev env (nsAppend (alist_to_ns env_v) (sev env)) ->
      expR st env' e_clause res ->
      expR st env (EMat e pes) res

  | expR_ELet : forall (st' : state A) (env' : sem_env val) (e1 e2 : exp) (v1 : val) (o : option varN) res,
      expR st env e1 (st', Rval v1) ->
      env' = update_sev env (nsOptBind o v1 (sev env)) ->
      expR st' env' e2 res ->
      expR st env (ELet o e1 e2) res

  | expR_ELetrec : forall (env': sem_env val) (e : exp) (funs : list (varN * varN * exp)) res,
      env' = update_sev env (build_rec_env funs env (sev env)) ->
      expR st env' e res ->
      expR st env (ELetrec funs e) res

  | expR_ETannot : forall (e : exp) (t : ast_t) res,
      expR st env e res ->
      expR st env (ETannot e t) res

  | expR_ELannot : forall (e : exp) (l : locs) res,
      expR st env e res ->
      expR st env (ELannot e l) res

(* [expListRevR st env es (st', Rval vs)] asserts that the expressions [es] evaluate to the list of values [vs]
   when evaluated in right-to-left order (mimics the [reverse es] and [reverse vs] from the Lem semantics),
   updating the state from [st] to [st']. *)

with expListRevR (A :Type) (st : state A) (env : sem_env val) : list exp -> ((state A) * result (list val) val) -> Prop :=

   | expListRevR_nil :
       expListRevR st env [] (st, Rval [])

   | expListRevR_cons : forall (st' st'' : state A) (e : exp) (v : val) (es : list exp) (vs : list val),
       expListRevR st env es (st', Rval vs) ->
       expR st' env e (st'', Rval v) ->
       expListRevR st env (e::es) (st'', Rval (v::vs)).

(* ---------------------------------------------------------------------- *)
(** ** Evaluation of top-level declarations *)

Inductive decR (A : Type) (st : state A) (env : sem_env val) : dec -> (state A) * (result (sem_env val) val) -> Prop :=

  | decR_Dlet : forall (st' : state A) env_v env' (l : locs) (p : pat) (e : exp) (v : val),
      TypeCheck (UniquePatBindings p) ->
      expR st env e (st', Rval v) ->
      pmatchR (sec env) (refs st') p v (Match env_v) ->
      env' = {| sev := alist_to_ns env_v; sec := nsEmpty |} ->
      decR st env (Dlet l p e) (st', Rval env')

  | decR_Dletrec : forall (env' : sem_env val) (l : locs) (funs : list (varN * varN * exp)),
      TypeCheck (UniqueRecIdent funs) ->
      env' = {| sev := build_rec_env funs env nsEmpty ; sec := nsEmpty |} ->
      decR st env (Dletrec l funs) (st, Rval env')

  | decR_Dtype : forall (env' : sem_env val) (st' : state A) (l : locs) (tds : typeDef),
      TypeCheck (UniqueCtorsInDefs tds) ->
      st' = state_update_next_type_stamp st (next_type_stamp st + length tds) ->
      env' = {| sev := nsEmpty ; sec := build_tdefs (next_type_stamp st) tds |} ->
      decR st env (Dtype l tds) (st', Rval env')

  | decR_Dtabbrev : forall (loc : locs) (tvs : list tvarN) (tn : typeN) (t : ast_t),
      decR st env (Dtabbrev loc tvs tn t) (st, Rval empty_sem_env)

  | decR_Dexn : forall (st' : state A) env' (loc : locs) (cn : conN) (ts : list ast_t),
      st' = state_update_next_exn_stamp st (next_exn_stamp st + 1) ->
      env' = {| sev := nsEmpty; sec := nsSing cn (length ts, ExnStamp (next_exn_stamp st)) |} ->
      decR st env (Dexn loc cn ts) (st', Rval env')

  | decR_Dmod : forall (st' : state A) (env' env'' : sem_env val) (mn : modN) (ds : list dec),
      decListR st env ds (st', Rval env') ->
      env'' = {| sev := nsLift mn (sev env'); sec := nsLift mn (sec env') |} ->
      decR st env (Dmod mn ds) (st', Rval env'')

  | decR_Dlocal : forall (st' : state A) (env' : sem_env val) (lds ds : list dec) res,
      decListR st env lds (st', Rval env') ->
      decListR st' (extend_dec_env env' env) ds res ->
      decR st env (Dlocal lds ds) res

with decListR (A : Type) (st : state A) (env : sem_env val) : list dec -> (state A) * (result (sem_env val) val) -> Prop :=

  | decR_Dnil :
      decListR st env [] (st, Rval empty_sem_env)

  | decR_DconsRval : forall (st' st'' : state A) (env1 env2 : sem_env val) (d : dec) (ds : list dec),
      decR st env d (st', Rval env1) ->
      decListR st' (extend_dec_env env1 env) ds (st'', Rval env2) ->
      decListR st env (d::ds) (st'', Rval (extend_dec_env env2 env1)).

(* ********************************************************************** *)
(** * Notes for future work *)

(*--------------------------------------------------------------
  LATER: treatment of exceptions and the propagation of exceptions

  | ERaise_R  : forall (st': state A) (e : exp) (v :val),
      expR st env e (st', Rval v) ->
      expR st env (ERaise e) (st', Rerr (Rraise v))
      expR st env e (st', Rerr (Rraise err_v)) ->
      matR st' env err_v l err_v (st'', r) ->
      expR st env (EHandle e l) (st'', r)

   | ArgsFail : forall (st' st'': state A) (res_val : result (list val) val) (err : error_result val) (e : exp) (es : list exp),
       expListRevR st env es (st', res_val) -> expR st' env e (st'', Rerr err) ->
       expListRevR st env (e::es) (st'', Rerr err)
   | ArgsPrevFail : forall (st' st'' : state A) (e : exp) (v : val) (es : list exp) (err : error_result val),
       expListRevR st env es (st', Rerr err) -> expListRevR st env (e::es) (st', Rerr err)
  | DconsRerr_R : forall (st' : state A) (d : dec) (ds : list dec) (res : result (sem_env val) val) (err_v : error_result val),
      decR st env d (st', res) ->
      combineDecResultR env res (Rerr err_v) ->
      decListR st env (d::ds) (st', Rerr err_v).

  | EMatVal_R : forall (env' : sem_env val) (e : exp) (pes : list (pat * exp)) (v : val) st' res,
      expR st env e (st', Rval v) ->
      matR st env v pes matchres ->
      (match matchres with
      | None -> res = (st, Rerr (Rraise bind_exn_v))
      | Some (env_clause, e_clause) ->
          let env' := extend_dec_env env_clause env in
          ---non strictly positive occurence here, so need to eliminate the match---
          expR st env' e_clause res
      end) ->
      expR st env (EMat e pes) res

  + fallthrough for every rule
    or a factorized fallthrough using pretty-big-step presentation

  | decR_Dmod_Fail : forall (st' : state A) (mn : modN) (ds : list dec) (d : list dec) (err_v : error_result val),
      decListR st env ds (st', Rerr err_v) ->
      decR st env (Dmod mn ds) (st', Rerr err_v)

  | decR_DletExpFail : forall (st' st'' : state A) (env' : sem_env val) (sto : store val) (l : locs)
                      (p : pat) (e : exp) (err_v : error_result val) (res : result (sem_env val) val),
      expR st env e (st', Rerr err_v) ->
      decR st env (Dlet l p e) (st', Rerr err_v)

  | decR_DletMatFail : forall (st' st'' : state A) (env' : sem_env val) (sto : store val) (l : locs)
                      (p : pat) (e : exp) (v : val) (res : result (sem_env val) val),
      expR st env e (st', Rval v) ->
      sto = refs st' ->
      pmatchR sto env p v No_match ->
      decR st env (Dlet l p e) (st', res)

  Inductive combineDecResultR (env : sem_env val) : result (sem_env val) val -> result (sem_env val) val -> Prop :=
    | combineRerr : forall (e : error_result val),
        combineDecResultR env (Rerr e) (Rerr e)
    | combineRval : forall (env' : sem_env val),
        combineDecResultR env (Rval env') (Rval {| sev := nsAppend (sev env') (sev env);
                                                   sec := nsAppend (sec env') (sec env) |}).

FUTURE WORK vectors

   | app_VfromList : forall s t v vs,
      v_to_list v = Some vs ->
      appR s t VfromList [v] s t (Vectorv vs)

    | (Vsub, [Vectorv vs; Litv (IntLit i)]) ->
        if i < 0 then
          Just ((s,t), Rerr (Rraise sub_exn_v))
        else
          let n = natFromInteger i in
            if n >= List.length vs then
              Just ((s,t), Rerr (Rraise sub_exn_v))
            else
              Just ((s,t), Rval (List_extra.nth vs n))
    | (Vlength, [Vectorv vs]) ->
        Just ((s,t), Rval (Litv (IntLit (integerFromNat (List.length vs)))))

FUTURE WORK more on arrays

  | app_AallocEmpty : forall s t n v s' lnum,
      (s',lnum) = store_alloc (Varray []) s ->
      appR s t AallocEmpty [ConvUnit) s' t (Loc lnum)

*)

(** QUESTION: would it make sense that the recursive closures store as environment not [env]
    but directly [env with v = build_rec_env funs env env.v], rather than rebuilding
    this extended environment each time? *)


Require Import Omega.
Require Import RelationClasses.

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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.

Set Implicit Arguments.

Lemma promise_step_promise_consistent
      lc1 mem1 loc from to msg lc2 mem2 kind
      (STEP: Local.promise_step lc1 mem1 loc from to msg lc2 mem2 kind)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. ii.
  destruct (Memory.op_kind_is_cancel kind) eqn:KIND.
  - destruct kind; ss. inv PROMISE.
    destruct (Memory.get loc0 ts promises2) as [[]|] eqn:GET2.
    + dup GET2. revert GET0.
      erewrite Memory.remove_o; eauto. condtac; ss. i.
      rewrite PROMISE0 in *. inv GET0. eauto.
    + revert GET2. erewrite Memory.remove_o; eauto. condtac; ss; i.
      * des. subst. exploit Memory.remove_get0; eauto. i. des. congr.
      * congr.
  - exploit Memory.promise_get1_promise; eauto. i. des.
    inv MSG_LE. exploit CONS; eauto.
Qed.

Lemma read_step_promise_consistent
      lc1 mem1 loc to val released ord lc2
      (STEP: Local.read_step lc1 mem1 loc to val released ord lc2)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. ii. exploit CONS; eauto. i.
  eapply TimeFacts.le_lt_lt; eauto. ss.
  etrans; [|apply Time.join_l]. etrans; [|apply Time.join_l]. refl.
Qed.

Lemma fulfill_unset_promises
      loc from ts msg
      promises1 promises2
      l t f m
      (FULFILL: Memory.remove promises1 loc from ts msg promises2)
      (TH1: Memory.get l t promises1 = Some (f, m))
      (TH2: Memory.get l t promises2 = None):
  l = loc /\ t = ts /\ f = from /\ Message.le msg m.
Proof.
  revert TH2. erewrite Memory.remove_o; eauto. condtac; ss; [|congr].
  des. subst. exploit Memory.remove_get0; eauto. i. des.
  rewrite GET in TH1. inv TH1.
  esplits; eauto. refl.
Qed.

Lemma write_step_promise_consistent
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
      (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. inv WRITE. ii.
  exploit Memory.promise_get1_promise; eauto.
  { inv PROMISE; ss. }
  i. des. inv MSG_LE.
  destruct (Memory.get loc0 ts promises2) as [[]|] eqn:X.
  - dup X. revert X0.
    erewrite Memory.remove_o; eauto. condtac; ss; i.
    rewrite GET in *. inv X0.
    apply CONS in X. eapply TimeFacts.le_lt_lt; eauto.
    s. etrans; [|apply Time.join_l]. refl.
  - exploit fulfill_unset_promises; eauto. i. des. subst.
    apply WRITABLE.
Qed.

Lemma fence_step_promise_consistent
      lc1 sc1 mem1 ordr ordw lc2 sc2
      (STEP: Local.fence_step lc1 sc1 ordr ordw lc2 sc2)
      (WF: Local.wf lc1 mem1)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. ii.
  exploit CONS; eauto. i.
  eapply TimeFacts.le_lt_lt; eauto.
  cut (TView.le (Local.tview lc1)
                (TView.write_fence_tview (TView.read_fence_tview (Local.tview lc1) ordr) sc1 ordw)).
  { i. inv H. apply CUR. }
  etrans.
  - eapply TViewFacts.write_fence_tview_incr. apply WF.
  - eapply TViewFacts.write_fence_tview_mon; try refl; try apply WF.
    eapply TViewFacts.read_fence_tview_incr. apply WF.
Qed.

Lemma ordering_relaxed_dec
      ord:
  Ordering.le ord Ordering.relaxed \/ Ordering.le Ordering.strong_relaxed ord.
Proof. destruct ord; auto. Qed.

Lemma step_promise_consistent
      lang pf e th1 th2
      (STEP: @Thread.step lang pf e th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  inv STEP; [inv STEP0|inv STEP0; inv LOCAL]; ss.
  - eapply promise_step_promise_consistent; eauto.
  - eapply read_step_promise_consistent; eauto.
  - eapply write_step_promise_consistent; eauto.
  - eapply read_step_promise_consistent; eauto.
    eapply write_step_promise_consistent; eauto.
  - eapply fence_step_promise_consistent; eauto.
  - eapply fence_step_promise_consistent; eauto.
Qed.

Lemma opt_step_promise_consistent
      lang e th1 th2
      (STEP: @Thread.opt_step lang e th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  inv STEP; eauto using step_promise_consistent.
Qed.

Lemma rtc_all_step_promise_consistent
      lang th1 th2
      (STEP: rtc (@Thread.all_step lang) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  revert_until STEP. induction STEP; auto. i.
  inv H. inv USTEP. exploit Thread.step_future; eauto. i. des.
  eapply step_promise_consistent; eauto.
Qed.

Lemma rtc_tau_step_promise_consistent
      lang th1 th2
      (STEP: rtc (@Thread.tau_step lang) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  eapply rtc_all_step_promise_consistent; cycle 1; eauto.
  eapply rtc_implies; [|eauto].
  apply tau_union.
Qed.

Lemma rtc_reserve_step_promise_consistent
      lang th1 th2
      (STEPS: rtc (@Thread.reserve_step lang) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2)):
  Local.promise_consistent (Thread.local th1).
Proof.
  ginduction STEPS; eauto. i. eapply IHSTEPS in CONS.
  inv H. inv STEP; inv STEP0; inv LOCAL. inv PROMISE. ss.
  ii. eapply Memory.add_get1 in PROMISE; eauto.
Qed.

Lemma rtc_cancel_step_promise_consistent
      lang th1 th2
      (STEPS: rtc (@Thread.cancel_step lang) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2)):
  Local.promise_consistent (Thread.local th1).
Proof.
  ginduction STEPS; eauto. i. eapply IHSTEPS in CONS.
  inv H. inv STEP; inv STEP0; inv LOCAL. inv PROMISE. ss.
  ii. dup PROMISE. eapply Memory.remove_get1 in PROMISE; eauto. des; eauto.
  clarify. eapply Memory.remove_get0 in PROMISES. des. clarify.
Qed.

Lemma rtc_reserve_step_promise_consistent2
      lang (th1 th2: Thread.t lang)
      (CONS: Local.promise_consistent (Thread.local th1))
      (STEPS: rtc (@Thread.reserve_step lang) th1 th2)
  :
    Local.promise_consistent (Thread.local th2).
Proof.
  ginduction STEPS; eauto.  i. eapply IHSTEPS.
  inv H. inv STEP; inv STEP0; inv LOCAL. inv PROMISE. ss.
  ii. erewrite Memory.add_o in PROMISE; eauto. des_ifs.
  eapply CONS; eauto.
Qed.

Lemma rtc_cancel_step_promise_consistent2
      lang (th1 th2: Thread.t lang)
      (CONS: Local.promise_consistent (Thread.local th1))
      (STEPS: rtc (@Thread.cancel_step lang) th1 th2)
  :
    Local.promise_consistent (Thread.local th2).
Proof.
  ginduction STEPS; eauto.  i. eapply IHSTEPS.
  inv H. inv STEP; inv STEP0; inv LOCAL. inv PROMISE. ss.
  ii. erewrite Memory.remove_o in PROMISE; eauto. des_ifs.
  eapply CONS; eauto.
Qed.

Lemma consistent_promise_consistent
      lang th
      (CONS: @Thread.consistent lang th)
      (WF: Local.wf (Thread.local th) (Thread.memory th))
      (SC: Memory.closed_timemap (Thread.sc th) (Thread.memory th))
      (MEM: Memory.closed (Thread.memory th)):
  Local.promise_consistent (Thread.local th).
Proof.
  destruct th. ss.
  exploit Memory.cap_exists; eauto. i. des.
  exploit Memory.cap_closed; eauto. i.
  exploit Local.cap_wf; eauto. i.
  exploit Memory.max_concrete_timemap_exists; try apply x0. i. des.
  hexploit Memory.max_concrete_timemap_closed; eauto. i.
  exploit CONS; eauto. s. i. des.
  - inv FAILURE. des. inv FAILURE; inv STEP. inv LOCAL. inv LOCAL0.
    hexploit rtc_tau_step_promise_consistent; try exact STEPS; eauto.
  - hexploit rtc_tau_step_promise_consistent; try exact STEPS; eauto.
    ii. rewrite PROMISES, Memory.bot_get in *. congr.
Qed.

Lemma promise_consistent_promise_read
      lc1 mem1 loc to val ord released lc2
      f t v r
      (STEP: Local.read_step lc1 mem1 loc to val released ord lc2)
      (PROMISE: Memory.get loc t (Local.promises lc1) = Some (f, Message.concrete v r))
      (CONS: Local.promise_consistent lc2):
  Time.lt to t.
Proof.
  inv STEP. exploit CONS; eauto. s. i.
  apply TimeFacts.join_lt_des in x. des.
  apply TimeFacts.join_lt_des in AC. des.
  revert BC0. unfold View.singleton_ur_if. condtac; ss.
  - unfold TimeMap.singleton, LocFun.add. condtac; ss.
  - unfold TimeMap.singleton, LocFun.add. condtac; ss.
Qed.

Lemma promise_consistent_promise_write
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
      f t v r
      (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (PROMISE: Memory.get loc t (Local.promises lc1) = Some (f, Message.concrete v r))
      (CONS: Local.promise_consistent lc2):
  Time.le to t.
Proof.
  destruct (Memory.get loc t (Local.promises lc2)) as [[]|] eqn:X.
  - inv STEP. inv WRITE. ss.
    dup X. revert X0.
    erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
    exploit Memory.promise_get1_promise; try exact PROMISE; eauto.
    { inv PROMISE0; ss. }
    i. des. inv MSG_LE.
    rewrite X0 in *. inv GET.
    exploit CONS; eauto. i. ss.
    apply TimeFacts.join_lt_des in x. des.
    left. revert BC. unfold TimeMap.singleton, LocFun.add. condtac; ss.
  - inv STEP. inv WRITE.
    exploit Memory.promise_get1_promise; eauto.
    { inv PROMISE0; ss. }
    i. des. inv MSG_LE.
    exploit fulfill_unset_promises; eauto. i. des. subst. refl.
Qed.


From Coq Require Import String ZArith Eqdep_dec.

From Vyper Require Import Config Calldag L10.Base.
From Vyper Require L20.AST L30.AST L20.Interpret L30.Interpret.

From Vyper.From20To30 Require Import Translate Callset.

Local Lemma translate_calldag_depthmap_ok {C: VyperConfig}
                                          (name: string)
                                          (cd: L20.Descend.calldag)
                                          (d: string_map L30.AST.decl):
   let _ := string_map_impl in
   forall E: map_maybe_map (cd_decls cd) translate_decl = inr d,
     match Map.lookup d name with
     | Some decl =>
         match cd_depthmap cd name with
         | Some x =>
             let _ := string_set_impl in
             FSet.for_all (Callset.decl_callset decl)
               (fun callee : string =>
                match cd_depthmap cd callee with
                | Some y => y <? x
                | None => false
                end) = true
         | None => False
         end
     | None => True
     end.
Proof.
intros.
remember (Map.lookup d name) as m.
destruct m. 2:trivial.
assert (D := cd_depthmap_ok cd name).
assert (F := map_maybe_map_ok E name).
destruct (Map.lookup (cd_decls cd) name). 2:{ now rewrite F in Heqm. }
destruct (cd_depthmap cd name). 2:assumption.
rewrite FSet.for_all_ok. rewrite FSet.for_all_ok in D.
intros x H.
remember (translate_decl d1) as d30.
destruct d30. { contradiction. }
rewrite<- Heqm in F. inversion F; subst.
rewrite (callset_translate_decl _ _ (eq_sym Heqd30)) in H.
apply (D x H).
Qed.

Definition translate_calldag {C: VyperConfig} (cd: L20.Descend.calldag)
: string + L30.Descend.calldag
:= let _ := string_map_impl in
   match map_maybe_map (cd_decls cd) translate_decl as cd' return _ = cd' -> _ with
   | inl err => fun _ => inl err
   | inr d => fun E => inr
     {| cd_decls := d
      ; cd_depthmap := cd_depthmap cd
      ; cd_depthmap_ok name := translate_calldag_depthmap_ok name cd d E
     |}
   end eq_refl.

(***************************************************************************************************)

Section FunCtx1.
  Context {C: VyperConfig}
          {bound: nat}
          {cd20: L20.Descend.calldag}
          {cd30: L30.Descend.calldag}
          (ok: translate_calldag cd20 = inr cd30).

  Lemma translate_fun_ctx_depthmap (name: string):
    cd_depthmap cd30 name
     =
    cd_depthmap cd20 name.
  Proof.
  destruct cd20.
  unfold translate_calldag in ok.
  cbn in *.
  remember (fun d (E : map_maybe_map cd_decls translate_decl = inr d) =>
         inr
           {|
           cd_decls := d;
           cd_depthmap := cd_depthmap;
           cd_depthmap_ok := fun name : string =>
                             translate_calldag_depthmap_ok name
                               {|
                               cd_decls := cd_decls;
                               cd_depthmap := cd_depthmap;
                               cd_depthmap_ok := cd_depthmap_ok |} d E |}) as good_branch.
  assert (K: forall (d30: string_map L30.AST.decl)
                    (E: map_maybe_map cd_decls translate_decl = inr d30),
               good_branch d30 E = inr cd30
                ->
               Calldag.cd_depthmap cd30 name = cd_depthmap name).
  {
    intros. subst.
    inversion H. now subst.
  }
  clear Heqgood_branch.
  destruct (map_maybe_map cd_decls translate_decl) as [|d30]. { discriminate. }
  apply (K d30 eq_refl ok).
  Qed.

  Lemma translate_fun_ctx_declmap (name: string):
    match cd_declmap cd20 name with
    | Some d => Some (translate_decl d)
    | None => None
    end
     =
    match cd_declmap cd30 name with
    | Some d => Some (inr d)
    | None => None
    end.
  Proof.
  destruct cd20.
  unfold translate_calldag in ok.
  cbn in *.
  remember (fun d (E : map_maybe_map cd_decls translate_decl = inr d) =>
         inr
           {|
           cd_decls := d;
           cd_depthmap := cd_depthmap;
           cd_depthmap_ok := fun name : string =>
                             translate_calldag_depthmap_ok name
                               {|
                               cd_decls := cd_decls;
                               cd_depthmap := cd_depthmap;
                               cd_depthmap_ok := cd_depthmap_ok |} d E |}) as good_branch.
  unfold cd_declmap. cbn.
  assert (K: forall (d30: string_map L30.AST.decl)
                    (E: map_maybe_map cd_decls translate_decl = inr d30),
               good_branch d30 E = inr cd30
                ->
               let _ := string_map_impl in
               match Map.lookup cd_decls name with
               | Some d => Some (translate_decl d)
               | None => None
               end = match Map.lookup (Calldag.cd_decls cd30) name with
                     | Some d => Some (inr d)
                     | None => None
                     end).
  {
    intros. subst.
    inversion H. subst.
    cbn.
    clear H ok.
    assert (M := map_maybe_map_ok E name).
    destruct (Map.lookup cd_decls name). 2:{ now destruct Map.lookup. }
    destruct (translate_decl d). { contradiction. }
    (* why rewrite M doesn't work? *)
    destruct Map.lookup. { now inversion M. }
    discriminate.
  }
  clear Heqgood_branch.
  destruct (map_maybe_map cd_decls translate_decl) as [|d30]. { discriminate. }
  apply (K d30 eq_refl ok).
  Qed.
End FunCtx1.

Section FunCtx2.
  Context {C: VyperConfig}
          {bound: nat}
          {cd20: L20.Descend.calldag}
          (fc: fun_ctx cd20 bound)
          {cd30: L30.Descend.calldag}
          (ok: translate_calldag cd20 = inr cd30).

  Local Lemma translate_fun_ctx_fun_decl_helper:
    cd_declmap cd30 (fun_name fc) <> None.
  Proof.
  intro E.
  assert (Ok := fun_decl_ok fc).
  assert (M := translate_fun_ctx_declmap ok (fun_name fc)).
  rewrite Ok in M.
  rewrite E in M.
  discriminate.
  Qed.

  Definition cached_translated_decl
  := match cd_declmap cd30 (fun_name fc)
     as d' return _ = d' -> _
     with
     | Some f => fun _ => f
     | None => fun E =>
          False_rect _ (translate_fun_ctx_fun_decl_helper E)
     end eq_refl.

  Local Lemma translate_fun_ctx_decl_ok:
    cd_declmap cd30 (fun_name fc)
     =
    Some cached_translated_decl.
  Proof.
  assert (D := fun_decl_ok fc).
  unfold cached_translated_decl.
  remember translate_fun_ctx_fun_decl_helper as foo. clear Heqfoo. revert foo.
  destruct (cd_declmap cd30 (fun_name fc)). { trivial. }
  intro. contradiction.
  Qed.

  Definition translate_fun_ctx
  : fun_ctx cd30 bound
  := let name := fun_name fc in
     {| fun_name := name
      ; fun_depth := fun_depth fc
      ; fun_depth_ok :=
          eq_trans (translate_fun_ctx_depthmap ok name)
                   (fun_depth_ok fc)
      ; fun_decl := cached_translated_decl
      ; fun_decl_ok := translate_fun_ctx_decl_ok
      ; fun_bound_ok := fun_bound_ok fc
     |}.
End FunCtx2.


Require Import Cosa.Lib.Header.
Require Import AST.
Require Import Memory.
Require Import Values.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Cosa.Lib.Predicate.
Require Import Cosa.Lib.Relation.

(** Concrete heap fragment are used as the concrete memory
    representation in the Cosa shape domain. A fragment is a Compcert
    C heap together with a predicate representing the memory currently
    accessible. It allows to reason separately on different fragment
    of the same heap, as in separation logic. *)

Definition fragment := (mem*℘ (block*Z.t))%type.

Definition star : fragment->fragment->fragment->Prop := Relation.pair teq disjoint_union.
Notation "h₁ ⋆ h₂ 'is' s" := (star h₁ h₂ s) (at level 15).

Definition estar := extension2 star.
Notation "h₁ ★ h₂" := (estar h₁ h₂) (at level 15).

Definition empty (h:fragment) : Prop := snd h = ∅.
Arguments empty h /.

Lemma empty_spec : empty = Predicate.pair (fun _ => True) (eq ∅).
Proof.
  apply Predicate.equiv_eq; intro h.
  unfold empty, Predicate.pair.
  firstorder.
Qed.

Instance star_assoc : Associative eq estar.
Proof.
  unfold estar,star; typeclasses eauto.
Qed.

Instance star_comm : Commutative eq estar.
Proof.
  unfold estar,star; typeclasses eauto.
Qed.

Corollary star_commutative_rel : forall h₁ h₂ s, h₁ ⋆ h₂ is s -> h₂ ⋆ h₁ is s.
Proof.
  intros h₁ h₂ s.
  apply commutative_rel.
  typeclasses eauto.
Qed.

Instance star_empty_neutral : LeftNeutral eq estar empty.
Proof.
  rewrite empty_spec.
  unfold estar,star; typeclasses eauto.
Qed.

Import ZArith. (* arnaud: y a-t-il un autre moyen de récupérer les notations de Z.t ? *)

(** [memory_range b off size] represents a contiguous zone of memory
    in block [b], starting at offset int and of size [size]. *)
Definition memory_range (b:block) (off:int) (chunk:memory_chunk) : (block*Z.t) -> Prop :=
  fun loc =>
    let '(b',off') := loc in
   (b' = b /\ Int.unsigned off <= off' /\ off' <= (Int.unsigned off)+(Memdata.size_chunk chunk))%Z
.

Definition valid (b:block) (off:int) (chunk:memory_chunk) (h:fragment) : Prop :=
  memory_range b off chunk ⊆ snd h
.

(** Lifts [Mem.loadv] to [fragment]. (spiwack:) I chose the semantics
    of [reads] to fail when accessling a zone of memory which isn't
    included in the accessible zone. I'm not sure whether it is the
    correct semantics. *)
Inductive reads (h:fragment) (chunk:memory_chunk) (b:block) (offs:int) (v:val) : Prop :=
| reads_intro :
    valid b offs chunk h ->
    Mem.loadv chunk (fst h) (Vptr b offs) = Some v ->
    reads h chunk b offs v
.

(** Variant of [read] taking the address as a value. *)
Definition readsv (h:fragment) (chunk: memory_chunk) (addr: val) (v:val) : Prop :=
  match addr with
  | Vptr b offs => reads h chunk b offs v
  | _ => False
  end
.

Lemma star_read_left h₁ h₂ s : h₁ ⋆ h₂ is s -> forall chunk b offs v,
                    reads h₁ chunk b offs v -> reads s chunk b offs v.
Proof.
  destruct h₁ as [ h₁ a₁ ].
  destruct h₂ as [ h₂ a₂ ].
  destruct s  as [ h_s a_s ].
  intros [ h₁h₂ disjoint ] c b offs v [ p₁ p₂ ].
  simpl in *.
  destruct h₁h₂.
  constructor.
  - unfold valid; simpl.
    intros x rnge.
    unfold disjoint_union in disjoint.
    destruct disjoint as [ disjoint union ].
    apply predicate_equality in union; unfold Predicate.equiv in union.
    apply union.
    left.
    now apply p₁.
  - easy.
Qed.

Corollary star_readv_left h₁ h₂ s : h₁ ⋆ h₂ is s -> forall chunk vaddr v,
                    readsv h₁ chunk vaddr v -> readsv s chunk vaddr v.
Proof.
  intros h *.
  destruct vaddr; simpl; trivial.
  eapply star_read_left; eauto.
Qed.

Lemma star_read_right h₁ h₂ s : h₁ ⋆ h₂ is s -> forall chunk b offs v,
                    reads h₂ chunk b offs v -> reads s chunk b offs v.
Proof.
  intros s_star **.
  apply star_commutative_rel in s_star.
  eapply star_read_left; eauto.
Qed.

Corollary star_readv_right h₁ h₂ s : h₁ ⋆ h₂ is s -> forall chunk vaddr v,
                    readsv h₂ chunk vaddr v -> readsv s chunk vaddr v.
Proof.
  intros h *.
  destruct vaddr; simpl; trivial.
  eapply star_read_right; eauto.
Qed.


From Perennial.program_proof.mvcc Require Import
     txn_prelude txnmgr_repr
     tid_proof.

Section program.
Context `{!heapGS Σ, !mvcc_ghostG Σ}.

(*****************************************************************)
(* func (txnMgr *TxnMgr) getMinActiveTIDSite(sid uint64) uint64  *)
(*****************************************************************)
Theorem wp_txnMgr__getMinActiveTIDSite txnmgr (sid : u64) γ :
  is_txnmgr txnmgr γ -∗
  {{{ ⌜int.Z sid < int.Z N_TXN_SITES⌝ }}}
    TxnMgr__getMinActiveTIDSite #txnmgr #sid
  {{{ (tid : u64), RET #tid; site_min_tid_lb γ sid (int.nat tid) }}}.
Proof.
  iIntros "#Htxnmgr" (Φ) "!> %Hbound HΦ".
  iNamed "Htxnmgr".
  iMod (readonly_load with "HsitesS") as (q) "HsitesS'".
  wp_call.

  (***********************************************************)
  (* site := txnMgr.sites[sid]                               *)
  (***********************************************************)
  wp_loadField.
  list_elem sitesL (int.nat sid) as site.
  { revert HsitesLen. unfold N_TXN_SITES in *. word. }
  wp_apply (wp_SliceGet with "[$HsitesS']").
  { iPureIntro.
    rewrite list_lookup_fmap.
    by rewrite Hsite_lookup.
  }
  iIntros "[HsitesS' _]".
  wp_pures.

  (***********************************************************)
  (* site.latch.Lock()                                       *)
  (***********************************************************)
  iDestruct (big_sepL_lookup with "HsitesRP") as "HsiteRP"; first done.
  iClear (latch) "Hlatch Hlock".
  iNamed "HsiteRP".
  wp_loadField.
  wp_apply (acquire_spec with "[$Hlock]").
  iIntros "[Hlocked HsiteOwn]".
  replace (U64 (Z.of_nat _)) with sid by word.
  iNamed "HsiteOwn".
  iDestruct (typed_slice.is_slice_sz with "HactiveL") as "%HtidsactiveSz".
  wp_pures.

  (***********************************************************)
  (* var tidnew uint64                                       *)
  (* tidnew = GenTID(sid)                                    *)
  (***********************************************************)
  wp_apply wp_ref_of_zero; first done.
  iIntros (tidRef) "HtidRef".
  wp_pures.
  wp_apply (wp_GenTID with "Hinvtid Hsidtok").
  { done. }
  (* Open the SST invariant to get [ts_auth]. *)
  iInv "Hinvsst" as "> HinvsstO" "HinvsstC".
  iDestruct (mvcc_inv_sst_ts_auth_acc with "HinvsstO") as (ts) "[Hts HinvtsC]".
  (* Open the GC invariant. *)
  iInv "Hinvgc" as "> HinvgcO" "HinvgcC".
  iDestruct (big_sepL_lookup_acc with "HinvgcO") as "[HinvsiteO HinvsiteC]".
  { by apply sids_all_lookup. }
  iNamed "HinvsiteO".
  (* Obtain [tidmax ≤ ts]. *)
  iDestruct (ts_auth_lb_le with "Hts Htslb") as %Hle.
  (* Agree on the active TIDs obtained from lock and global invariants. *)
  iDestruct (site_active_tids_agree with "HactiveA HactiveAuth") as %->.
  (* Give atomic precondition. *)
  iExists _. iFrame "Hts".
  iApply ncfupd_mask_intro; first set_solver.
  iIntros "Hclose".
  iIntros "%tsnew (Htsnew & %Hlt)". rename ts into tsold.
  (* Update the minimal TID to the smallest among [{[ tsnew ]} ∪ tidsactiveM]. *)
  set tids := {[ tsnew ]} ∪ tidsactiveM.
  assert (∃ tidmin', set_Forall (λ tid, (tidmin' ≤ tid)%nat) tids ∧ tidmin' ∈ tids)
    as (tidmin' & Htidmin' & Helem).
  { destruct (minimal_exists_L Nat.le tids) as (tidx & Htidx & Hminimal); first set_solver.
    exists tidx.
    split; last done.
    rewrite minimal_anti_symm in Hminimal.
    intros tidy Htidy.
    destruct (decide (tidx ≤ tidy)%nat); first done.
    apply Hminimal in Htidy; lia.
  }
  iMod (site_min_tid_update tidmin' with "HminA") as "HminA".
  { rewrite elem_of_union in Helem.
    destruct Helem; last by auto.
    (* Case [tidmin' = ts]. *)
    rewrite elem_of_singleton in H.
    rewrite H.
    apply set_Forall_union_inv_1, set_Forall_singleton in Hmax.
    lia.
  }
  iDestruct (site_min_tid_witness with "HminA") as "#Hminlb".
  iClear "Htslb".
  iDestruct (ts_witness with "Htsnew") as "#Htslb".
  iMod "Hclose" as "_".
  (* Close the GC invariant. *)
  iDestruct ("HinvsiteC" with "[HactiveA HminA]") as "HinvsiteO".
  { iExists _, _, tsnew.
    iFrame "∗ Htslb".
    iPureIntro.
    split.
    { eapply set_Forall_subseteq; last apply Htidmin'. set_solver. }
    { (* apply set_Forall_union_inv_1 in Hmax as Hminmax.
      rewrite set_Forall_singleton in Hminmax. *)
      apply set_Forall_union.
      { rewrite set_Forall_singleton.
        apply set_Forall_union_inv_1 in Htidmin'.
        rewrite set_Forall_singleton in Htidmin'. lia.
      }
      { apply set_Forall_union_inv_2 in Hmax.
        eapply set_Forall_impl; first apply Hmax.
        word.
      }
    }
  }
  iMod ("HinvgcC" with "HinvsiteO") as "_".
  iDestruct ("HinvtsC" with "[] Htsnew") as "HinvsstO".
  { iPureIntro. lia. }
  iMod ("HinvsstC" with "HinvsstO") as "_".
  iModIntro.
  iIntros (tidnew) "[%Etidnew Hsidtok]".
  subst tsnew.
  wp_store.

  (***********************************************************)
  (* machine.Assume(tidnew < 18446744073709551615)           *)
  (***********************************************************)
  wp_load.
  wp_apply wp_Assume.
  iIntros (Hoverflow).
  apply bool_decide_eq_true_1 in Hoverflow.

  (***********************************************************)
  (* var tidmin uint64 = tidnew                              *)
  (***********************************************************)
  wp_load.
  wp_apply (wp_ref_to); first by auto.
  iIntros (tidminRef) "HtidminRef".
  wp_pures.

  (***********************************************************)
  (* for _, tid := range site.tidsActive {                   *)
  (*     if tid < tidmin {                                   *)
  (*         tidmin = tid                                    *)
  (*     }                                                   *)
  (* }                                                       *)
  (***********************************************************)
  set u64_to_nat := (λ x : u64, int.nat x).
  iDestruct (is_slice_small_acc with "HactiveL") as "[HactiveS HactiveC]".
  wp_loadField.
  set P := λ (i : u64), (∃ (tidloop : u64), let tids := tidnew :: (take (int.nat i) tidsactiveL) in
    "HtidminRef" ∷ tidminRef ↦[uint64T] #tidloop ∗
    "%Helem'" ∷ ⌜tidloop ∈ tids⌝ ∗
    "%Htidloop" ∷ (⌜Forall (λ tid, (int.nat tidloop ≤ tid)%nat) (u64_to_nat <$> tids)⌝))%I.
  wp_apply (typed_slice.wp_forSlice P _ _ _ _ _ tidsactiveL with "[] [HtidminRef $HactiveS]").
  { clear Φ.
    iIntros (i tidx Φ) "!> (Hloop & %Hbound' & %Hlookup) HΦ".
    iNamed "Hloop".
    wp_load.
    wp_if_destruct.
    - wp_store.
      iApply "HΦ".
      iModIntro.
      iExists _.
      iFrame.
      do 2 replace (int.nat (word.add i 1)) with (S (int.nat i)) by word.
      rewrite (take_S_r _ _ tidx); last done.
      iSplit; iPureIntro.
      { set_solver. }
      { rewrite app_comm_cons fmap_app.
        rewrite Forall_app.
        split.
        { apply (Forall_impl _ _ _ Htidloop). word. }
        apply Forall_singleton. done.
      }
    - iApply "HΦ".
      iModIntro.
      iExists _.
      iFrame.
      do 2 replace (int.nat (word.add i 1)) with (S (int.nat i)) by word.
      rewrite (take_S_r _ _ tidx); last done.
      iSplit; iPureIntro.
      { set_solver. }
      { rewrite app_comm_cons fmap_app.
        rewrite Forall_app.
        split.
        { apply (Forall_impl _ _ _ Htidloop). word. }
        apply Forall_singleton. subst u64_to_nat. word.
      }
  }
  { iExists _.
    iFrame.
    iPureIntro.
    rewrite take_0.
    rewrite Forall_forall.
    split; set_solver.
  }
  iIntros "[Hloop HactiveS]".
  subst P. simpl. iNamed "Hloop".
  wp_pures.

  (***********************************************************)
  (* site.latch.Unlock()                                     *)
  (***********************************************************)
  iDestruct ("HactiveC" with "HactiveS") as "HactiveL".
  wp_loadField.
  wp_apply (release_spec with "[-HΦ HtidminRef]").
  { eauto 10 with iFrame. }
  wp_pures.

  (***********************************************************)
  (* return tidmin                                           *)
  (***********************************************************)
  (* Deduce [tidmin' = tidloop]. *)
  rewrite -HtidsactiveSz firstn_all in Htidloop Helem'.
  replace tidmin' with (int.nat tidloop); last first.
  { subst tids tidsactiveM.
    clear -Helem Htidmin' Helem' Htidloop.
    rewrite -list_to_set_cons elem_of_list_to_set in Helem.
    rewrite -list_to_set_cons set_Forall_list_to_set in Htidmin'.
    replace (int.nat tidnew) with (u64_to_nat tidnew) in Helem, Htidmin'; last done.
    rewrite -fmap_cons in Helem Htidmin'.
    apply (elem_of_list_fmap_1 u64_to_nat) in Helem'.
    rewrite Forall_forall in Htidmin'.
    rewrite Forall_forall in Htidloop.
    apply Htidmin' in Helem'.
    apply Htidloop in Helem.
    subst u64_to_nat. word.
  }
  wp_load.
  by iApply "HΦ".
Qed.

(*****************************************************************)
(* func (txnMgr *TxnMgr) getMinActiveTID() uint64                *)
(*****************************************************************)
Theorem wp_txnMgr__getMinActiveTID txnmgr γ :
  is_txnmgr txnmgr γ -∗
  {{{ True }}}
    TxnMgr__getMinActiveTID #txnmgr
  {{{ (tid : u64), RET #tid; min_tid_lb γ (int.nat tid) }}}.
Proof.
  iIntros "#Htxnmgr" (Φ) "!> _ HΦ".
  wp_call.

  (***********************************************************)
  (* var min uint64 = config.TID_SENTINEL                    *)
  (***********************************************************)
  wp_apply (wp_ref_to); first auto.
  iIntros (minRef) "HminRef".
  wp_pures.

  (***********************************************************)
  (* for sid := uint64(0); sid < config.N_TXN_SITES; sid++ { *)
  (*     tid := txnMgr.getMinActiveTIDSite(sid)              *)
  (*     if tid < min {                                      *)
  (*         min = tid                                       *)
  (*     }                                                   *)
  (* }                                                       *)
  (***********************************************************)
  wp_apply (wp_ref_to); first auto.
  iIntros (sidRef) "HsidRef".
  wp_pures.
  set P := λ (i : u64), (∃ (tidmin : u64),
    "HminRef" ∷ minRef ↦[uint64T] #tidmin ∗
    "Htidlbs" ∷ [∗ list] sid ∈ (take (int.nat i) sids_all), site_min_tid_lb γ sid (int.nat tidmin))%I.
  wp_apply (wp_forUpto P _ _ (U64 0) (U64 N_TXN_SITES) sidRef with "[] [HminRef HsidRef]"); first done.
  { clear Φ.
    iIntros (i Φ) "!> (Hloop & HsidRef & %Hbound) HΦ".
    iNamed "Hloop".
    wp_pures.
    wp_load.
    wp_apply (wp_txnMgr__getMinActiveTIDSite with "Htxnmgr"); first done.
    iIntros (tid) "Htidlb".
    wp_pures.
    wp_load.
    wp_pures.

    wp_if_destruct.
    - (* Find new min. *)
      wp_store.
      iApply "HΦ".
      iModIntro.
      iFrame.
      iExists _.
      iFrame.
      replace (int.nat (word.add _ _)) with (S (int.nat i)); last by word.
      rewrite (take_S_r _ _ i); last by apply sids_all_lookup.
      iApply big_sepL_app.
      iSplitL "Htidlbs".
      { iApply (big_sepL_impl with "Htidlbs").
        iModIntro.
        iIntros (iN sid) "Hlookup Htidlb".
        (* Weaken all previous lower bounds. *)
        iApply (site_min_tid_lb_weaken with "Htidlb").
        word.
      }
      { simpl. auto. }
    - (* Same min. *)
      iApply "HΦ".
      iModIntro.
      iFrame.
      iExists _.
      iFrame.
      replace (int.nat (word.add _ _)) with (S (int.nat i)); last by word.
      rewrite (take_S_r _ _ i); last by apply sids_all_lookup.
      iApply big_sepL_app.
      iSplitL "Htidlbs"; first done.
      simpl.
      iSplit; last done.
      (* Weaken the current lower bound. *)
      iApply (site_min_tid_lb_weaken with "Htidlb").
      word.
  }
  { iFrame.
    iExists _.
    iFrame.
    replace (int.nat 0) with 0%nat; last word.
    rewrite take_0.
    auto.
  }
  iIntros "[Hloop HsidRef]".
  iNamed "Hloop".
  wp_pures.

  (***********************************************************)
  (* return min                                              *)
  (***********************************************************)
  wp_load.
  by iApply "HΦ".
Qed.

End program.


Require Import Coqlib Maps String.
Require Import AST Integers Values Events Memory Globalenvs Smallstep.
Require Import Op Registers.

Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope error_monad_scope.

Inductive type: Type :=
    | Uint8   : type
    | Uint16  : type
    | Uint32  : type
    | Uint64  : type
    | Int8    : type
    | Int16   : type
    | Int32   : type
    | Int64   : type
    | Float32 : type
    | Float64 : type
    | Bool    : type.

Definition alltypes : list type :=
    Uint8 :: Uint16 :: Uint32 :: Uint64 :: Int8 :: Int16 :: Int32 :: Int64 :: Float32 :: Float64 :: Bool :: nil.

Definition type_size (ty: type) : Z :=
    match ty with
    | Uint8   => 1
    | Uint16  => 2
    | Uint32  => 4
    | Uint64  => 8
    | Int8    => 1
    | Int16   => 2
    | Int32   => 4
    | Int64   => 8
    | Float32 => 4
    | Float64 => 8
    | Bool    => 1 (*Since compcert C treats bools as 8-bit ints *)
    end.

Definition type_to_string (t: type) : string :=
    match t with
    | Uint8   => "uint8"
    | Uint16  => "uint16"
    | Uint32  => "uint32"
    | Uint64  => "uint64"
    | Int8    => "int8"
    | Int16   => "int16"
    | Int32   => "int32"
    | Int64   => "int64"
    | Float32 => "float32"
    | Float64 => "float64"
    | Bool    => "bool"
    end.

Definition string_to_type (s: string) : option type :=
    match s with
    | "uint8"   => Some Uint8
    | "uint16"  => Some Uint16
    | "uint32"  => Some Uint32
    | "uint64"  => Some Uint64
    | "int8"    => Some Int8
    | "int16"   => Some Int16
    | "int32"   => Some Int32
    | "int64"   => Some Int64
    | "float32" => Some Float32
    | "float64" => Some Float64
    | "bool"    => Some Bool
    | _         => None
    end.

Definition index: Type := N.

Definition val: Type := init_data.

Inductive location_val: Type :=
  | Imm      : (val + ident) -> location_val
  | Reg      : index -> location_val
  | Stack    : index -> location_val.

Definition offset: Type := location_val.

Inductive location_ref: Type :=
  | Ref      : index -> location_ref
  | Cref     : index -> location_ref
  | Mem      : location_val -> location_ref.

Inductive location_mov : Type :=
  | MV : location_val -> location_mov
  | MR : location_ref -> offset -> location_mov.

Inductive location : Type :=
  | LV : location_val -> location
  | LR : location_ref -> location.

Definition nbytes: Type := location_val.

Inductive instruction: Type :=

  (* Common instructions *)
  | Ipush         : location_val -> instruction
  | Ipushref      : location -> instruction
  | Ipushrefpart  : location -> offset -> nbytes -> instruction
  | Ipushcref     : location -> instruction
  | Ipushcrefpart : location -> offset -> nbytes -> instruction
  | Imov          : location_mov -> location_mov -> option nbytes -> instruction
  | Icall         : location_val -> option location_val -> instruction
  | Isyscall      : location_val -> option location_val -> instruction
  | Ialloc        : location_val -> nbytes -> instruction
  | Ifree         : location_val -> instruction
  | Igetmemsize   : location_val -> location_val -> instruction
  | Iresizestack  : val -> instruction
  | Ilabel        : ident -> instruction
  | Ireturn       : location_val -> instruction
  | Ihalt         : location_val -> instruction
  | Iuser_except  : instruction
  | Iconvert      : type -> location_val -> type -> location_val -> instruction

  (* Unary arithmetic operations *)
  | Iudec         : type -> location_val -> instruction  (* d := d - 1 *)
  | Iuinc         : type -> location_val -> instruction  (* d := d + 1 *)

  (* Binary arithmetic operations *)
  | Ibadd         : type -> location_val -> location_val -> instruction  (* d := d + s *)
  | Ibsub         : type -> location_val -> location_val -> instruction  (* d := d - s *)

  (* Terniary arithmetic operations *)
  | Itadd         : type -> location_val -> location_val -> location_val -> instruction  (* d := s1 + s2 *)
  | Itsub         : type -> location_val -> location_val -> location_val -> instruction  (* d := s1 - s2 *)
  | Itmul         : type -> location_val -> location_val -> location_val -> instruction  (* d := s1 * s2 *)

  (* Jump operations *)
  | Ijmp          : location_val -> instruction
  | Ijz           : location_val -> type -> location_val -> instruction
  | Ijnz          : location_val -> type -> location_val -> instruction
  | Idnjz         : location_val -> type -> location_val -> instruction
  | Idnjnz        : location_val -> type -> location_val -> instruction
  | Ijeq          : location_val -> type -> location_val -> location_val -> instruction
  | Ijne          : location_val -> type -> location_val -> location_val -> instruction
  | Ijge          : location_val -> type -> location_val -> location_val -> instruction
  | Ijgt          : location_val -> type -> location_val -> location_val -> instruction
  | Ijle          : location_val -> type -> location_val -> location_val -> instruction
  | Ijlt          : location_val -> type -> location_val -> location_val -> instruction

  (* Logical operations *)
  | Iteq          : type -> location_val -> location_val -> location_val -> instruction
  | Itne          : type -> location_val -> location_val -> location_val -> instruction
  | Itge          : type -> location_val -> location_val -> location_val -> instruction
  | Itgt          : type -> location_val -> location_val -> location_val -> instruction
  | Itle          : type -> location_val -> location_val -> location_val -> instruction
  | Itlt          : type -> location_val -> location_val -> location_val -> instruction

  (* Ternary bitwise operations *)
  | Ibtand        : type -> location_val -> location_val -> location_val -> instruction
  | Itshr0        : type -> location_val -> location_val -> location_val -> instruction
  .

Definition comparison: Type := location_val -> type -> location_val -> location_val -> instruction.
Definition comparison_bool: Type := type -> location_val -> location_val -> location_val -> instruction.

Definition code: Type := list instruction.

Definition private_domain : Type := string.
Definition external_function : Type := string.

(* a block starts with a label and has only relative jumps or jumps to other blocks. It returns at the end *)
Definition block: Type := (ident * code).

Definition blocks: Type := PTree.t code.

Inductive sharemind_data: Type :=
    | Data_string : string -> sharemind_data
    | Data_uint8 : int -> sharemind_data
    .

Record program (E: Type) : Type := mkprogram {
  prog_pds: PTree.t private_domain;
  prog_rodata: PTree.t sharemind_data;
  prog_exts: PTree.t E;
  prog_init: code;
  prog_code: blocks
}.

Definition noprogram (E: Type) : (program E) := mkprogram E
    (PTree.empty private_domain)
    (PTree.empty sharemind_data)
    (PTree.empty E)
    nil
    (PTree.empty code).


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                 Xavier Leroy, INRIA Paris                           *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Recognition of combined operations, addressing modes and conditions
  during the [CSE] phase. *)

Require Import Coqlib.
Require Import AST Integers.
Require Import Op CSEdomain.

Definition valnum := positive.

Section COMBINE.

Variable get: valnum -> option rhs.

Function combine_compimm_ne_0 (x: valnum) : option(condition * list valnum) :=
  match get x with
  | Some(Op (Ocmp c) ys) => Some (c, ys)
  | Some(Op (Oandimm n) ys) => Some (Cmasknotzero n, ys)
  | _ => None
  end.

Function combine_compimm_eq_0 (x: valnum) : option(condition * list valnum) :=
  match get x with
  | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys)
  | Some(Op (Oandimm n) ys) => Some (Cmaskzero n, ys)
  | _ => None
  end.

Function combine_compimm_eq_1 (x: valnum) : option(condition * list valnum) :=
  match get x with
  | Some(Op (Ocmp c) ys) => Some (c, ys)
  | _ => None
  end.

Function combine_compimm_ne_1 (x: valnum) : option(condition * list valnum) :=
  match get x with
  | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys)
  | _ => None
  end.

Function combine_cond (cond: condition) (args: list valnum) : option(condition * list valnum) :=
  match cond, args with
  | Ccompimm Cne n, x::nil =>
      if Int.eq_dec n Int.zero then combine_compimm_ne_0 x
      else if Int.eq_dec n Int.one then combine_compimm_ne_1 x
      else None
  | Ccompimm Ceq n, x::nil =>
      if Int.eq_dec n Int.zero then combine_compimm_eq_0 x
      else if Int.eq_dec n Int.one then combine_compimm_eq_1 x
      else None
  | Ccompuimm Cne n, x::nil =>
      if Int.eq_dec n Int.zero then combine_compimm_ne_0 x
      else if Int.eq_dec n Int.one then combine_compimm_ne_1 x
      else None
  | Ccompuimm Ceq n, x::nil =>
      if Int.eq_dec n Int.zero then combine_compimm_eq_0 x
      else if Int.eq_dec n Int.one then combine_compimm_eq_1 x
      else None
  | _, _ => None
  end.

Function combine_addr_32 (addr: addressing) (args: list valnum) : option(addressing * list valnum) :=
  match addr, args with
  | Aindexed n, x::nil =>
      match get x with
      | Some(Op (Olea a) ys) =>
          match offset_addressing a n with Some a' => Some (a', ys) | None => None end
      | _ => None
      end
  | _, _ => None
  end.

Function combine_addr_64 (addr: addressing) (args: list valnum) : option(addressing * list valnum) :=
  match addr, args with
  | Aindexed n, x::nil =>
      match get x with
      | Some(Op (Oleal a) ys) =>
          match offset_addressing a n with Some a' => Some (a', ys) | None => None end
      | _ => None
      end
  | _, _ => None
  end.

Definition combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) :=
  if Archi.ptr64 then combine_addr_64 addr args else combine_addr_32 addr args.

Function combine_op (op: operation) (args: list valnum) : option(operation * list valnum) :=
  match op, args with
  | Olea addr, _ =>
      match combine_addr_32 addr args with
      | Some(addr', args') => Some(Olea addr', args')
      | None => None
      end
  | Oleal addr, _ =>
      match combine_addr_64 addr args with
      | Some(addr', args') => Some(Oleal addr', args')
      | None => None
      end
  | Oandimm n, x :: nil =>
      match get x with
      | Some(Op (Oandimm m) ys) => Some(Oandimm (Int.and m n), ys)
      | _ => None
      end
  | Oorimm n, x :: nil =>
      match get x with
      | Some(Op (Oorimm m) ys) => Some(Oorimm (Int.or m n), ys)
      | _ => None
      end
  | Oxorimm n, x :: nil =>
      match get x with
      | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys)
      | _ => None
      end
  | Oandlimm n, x :: nil =>
      match get x with
      | Some(Op (Oandlimm m) ys) => Some(Oandlimm (Int64.and m n), ys)
      | _ => None
      end
  | Oorlimm n, x :: nil =>
      match get x with
      | Some(Op (Oorlimm m) ys) => Some(Oorlimm (Int64.or m n), ys)
      | _ => None
      end
  | Oxorlimm n, x :: nil =>
      match get x with
      | Some(Op (Oxorlimm m) ys) => Some(Oxorlimm (Int64.xor m n), ys)
      | _ => None
      end
  | Ocmp cond, _ =>
      match combine_cond cond args with
      | Some(cond', args') => Some(Ocmp cond', args')
      | None => None
      end
  | _, _ => None
  end.

End COMBINE.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_onFailToRecoverStake (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Opaque DePoolContract_Ф_startRoundCompleting.

Lemma DePoolContract_Ф_onFailToRecoverStake_exec : forall ( Л_queryId : XInteger64 )
                                                          ( Л_elector : XAddress )
                                                           (l: Ledger) ,

let optRound := eval_state ( ↓ ( RoundsBase_Ф_fetchRound Л_queryId ) ) l in
let req1 : bool := isSome optRound in
let round := maybeGet optRound in
let req2 : bool := eval_state msg_sender  l  =?  round ->> RoundsBase_ι_Round_ι_proxy  in
let req3 : bool :=  Л_elector =? ( round ->> RoundsBase_ι_Round_ι_elector ) in
let la :=  exec_state (↓ tvm_accept) l in
let if1 : bool := ( eqb ( round ->> RoundsBase_ι_Round_ι_step ) RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections ) in
let if2 : bool := ( eqb ( round ->> RoundsBase_ι_Round_ι_step ) RoundsBase_ι_RoundStepP_ι_WaitingReward ) in
let (round', l') := if if1 then ({$ round with ( RoundsBase_ι_Round_ι_step , RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze ) $}, la)
                    else if if2  then
  run ( ↓ ( DePoolContract_Ф_startRoundCompleting round RoundsBase_ι_CompletionReasonP_ι_ValidatorIsPunished ) ) la
               else (round, injEmbed (VMState_ι_savedDePoolContracts (Ledger_ι_VMState l)) la) in

exec_state ( ↓ DePoolContract_Ф_onFailToRecoverStake Л_queryId Л_elector ) l =
if req1 then
        if req2 then
                if req3 then
if if1 then exec_state ( ↓ ( RoundsBase_Ф_setRound Л_queryId round' ) ) l'
       else if if2 then exec_state ( ↓ ( RoundsBase_Ф_setRound Л_queryId round' ) ) l'
               else l'
               else l else l else l.
Proof.
        intros.
        destructLedger l.
        compute.

        Time repeat destructIf_solve. idtac.

        all: try destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

Qed.

Lemma DePoolContract_Ф_onFailToRecoverStake_eval : forall ( Л_queryId : XInteger64 )
                                                          ( Л_elector : XAddress )
                                                           (l: Ledger) ,
let optRound := eval_state ( ↓ ( RoundsBase_Ф_fetchRound Л_queryId ) ) l in
let req1 : bool := isSome optRound in
let round := maybeGet optRound in
let req2 : bool := eval_state msg_sender  l  =?  round ->> RoundsBase_ι_Round_ι_proxy  in
let req3 : bool :=  Л_elector =? ( round ->> RoundsBase_ι_Round_ι_elector ) in
let la :=  exec_state (↓ tvm_accept) l in
let if1 : bool := ( eqb ( round ->> RoundsBase_ι_Round_ι_step ) RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections ) in
let if2 : bool := ( eqb ( round ->> RoundsBase_ι_Round_ι_step ) RoundsBase_ι_RoundStepP_ι_WaitingReward ) in

eval_state ( ↓ DePoolContract_Ф_onFailToRecoverStake Л_queryId Л_elector ) l =
if req1 then
        if req2 then
                if req3 then
if if1 then Value I
       else if if2 then Value I
               else Error InternalErrors_ι_ERROR521
                        else Error Errors_ι_IS_NOT_ELECTOR
                else Error Errors_ι_IS_NOT_PROXY
        else Error InternalErrors_ι_ERROR513 .
Proof.

        intros.
        destructLedger l.
        compute.

        Time repeat destructIf_solve. idtac.

        all: try destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

Qed.

End DePoolContract_Ф_onFailToRecoverStake.


From stdpp Require Import numbers countable.
From Formalisation Require Import Span SizeNat Inject IsFresh ZeroCopy.
From Classes Require Import Foldable.
Require Import Vector.
From Equations Require Import Equations.
Import disjoint.

Definition Bit := bool.

Class ValuesFormat (X : Type) :=
  mk_values {
      size : nat;
      encode : X -> Vector.t Bit size;
      decode : Vector.t Bit size -> option X;
      spec : forall (x : X), decode (encode x) = Some x; }.

Local Instance ValuesBool : ValuesFormat bool.
refine (mk_values bool 1
          (fun b => cons b nil)
          (fun v => match v with
                 | cons b _ => Some b
                 | _ => None
                 end) _).
intros. reflexivity.
Defined.

Class Etiquette `{Countable etiquette} :=
  mk_etiquette {
      set_etiquette : gset etiquette;
      set_etiquette_spec: forall (e : etiquette), e ∈ set_etiquette; }.

Inductive Result :=
| Value : forall `{ValuesFormat X}, X -> Result
| Span : span -> Result
| Struct : forall `{Etiquette etiquette}, (etiquette -> Result) -> Result.

Arguments Value [X _].
Arguments Struct [etiquette _ _ _].

Definition list_etiquette {X} `{Etiquette X} := elements set_etiquette.

Fixpoint Result_to_list (t: Result) : list span :=
  match t with
  | Value _ => []
  | Span s => [s]
  | Struct st =>
      list.foldr (fun eti r => Result_to_list (st eti) ++ r) [] list_etiquette
  end.

Definition Decodeur := span -> option Result.

Open Scope N_scope.

Fixpoint ResultWeakZC (s : span) (r : Result) : Prop :=
  match r with
  | Value _ => True
  | Span v => scope_in v s
  | Struct ft => forall e, ResultWeakZC s (ft e)
  end.

Definition DecodeurWeakZC (d: Decodeur) :=
  forall s ft,
    d s = Some ft ->
    ResultWeakZC s ft.

Fixpoint ResultZC (s : span) (r : Result) : Prop :=
  match r with
  | Value _ => False
  | Span v => scope_in v s
  | Struct ft => forall e, ResultZC s (ft e)
  end.

Definition DecodeurZC (d : Decodeur) :=
  forall s ft,
    d s = Some ft ->
    ResultZC s ft.

(** Version tous les spans de la structures sont disjointes deux à deux **)

Definition Result_safe (r : Result) : Prop :=
  forall s t, s <> t -> s ∈ Result_to_list r -> t ∈ Result_to_list r -> disjoint s t.

(** Version SL **)

Definition Result_safeSL (r : Result) : iProp :=
  [∗ list] v ∈ Result_to_list r, IsFresh v.

Theorem safe_bridge : forall (r : Result), Result_safeSL r ⊢ ⌜ Result_safe r ⌝.
Proof.
  unfold Result_safe. induction r; simpl; intros.
  - iIntros "HA". iPureIntro. intros s t NEQ F. inversion F.
  - iIntros "HA". iPureIntro. intros t0 t1 NEQ INt0 INt1.
    eapply elem_of_list_singleton in INt0. eapply elem_of_list_singleton in INt1.
    subst. contradiction.
  - iIntros "HA" (s t NEQ INs INt).
    unfold Result_safeSL. simpl.
    eapply elem_of_list_lookup_1 in INs as [Is Ps].
    eapply elem_of_list_lookup_1 in INt as [It Pt].
    iDestruct (big_sepL_delete with "HA") as "[Hs HA]". eapply Ps.
    iDestruct (big_sepL_delete with "HA") as "[Ht HA]". eapply Pt.
    destruct (decide (It = Is)).
    + subst. rewrite Ps in Pt. injection Pt. intro. contradiction.
    + iClear "HA". iApply (IsFresh_spec with "Hs Ht").
Qed.

Definition DecodeurZC_safe (d : Decodeur) :=
  forall s ft, d s = Some ft -> Result_safe ft.


Require Import VST.floyd.proofauto.
Require Import VST.progs.append.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition t_struct_list := Tstruct _list noattr.

Fixpoint listrep (sh: share)
            (contents: list val) (x: val) : mpred :=
 match contents with
 | h::hs =>
              EX y:val,
                data_at sh t_struct_list (h,y) x * listrep sh hs y
 | nil => !! (x = nullval) && emp
 end.

Arguments listrep sh contents x : simpl never.

Lemma listrep_local_facts:
  forall sh contents p,
     listrep sh contents p |--
     !! (is_pointer_or_null p /\ (p=nullval <-> contents=nil)).
Proof.
intros.
revert p; induction contents; unfold listrep; fold listrep; intros; normalize.
apply prop_right; split; simpl; auto. intuition.
entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sh contents p,
   sepalg.nonidentity sh ->
   listrep sh contents p |-- valid_pointer p.
Proof.
 destruct contents; unfold listrep; fold listrep; intros; normalize.
 auto with valid_pointer.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto. simpl;  computable.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma listrep_null: forall sh contents,
    listrep sh contents nullval = !! (contents=nil) && emp.
Proof.
destruct contents; unfold listrep; fold listrep.
normalize.
apply pred_ext.
Intros y. entailer. destruct H; contradiction.
Intros.
Qed.

Lemma is_pointer_or_null_not_null:
 forall x, is_pointer_or_null x -> x <> nullval -> isptr x.
Proof.
intros.
 destruct x; try contradiction. hnf in H; subst i. contradiction H0; reflexivity.
 apply I.
Qed.

Definition append_spec :=
 DECLARE _append
  WITH sh : share, x: val, y: val, s1: list val, s2: list val
  PRE [ _x OF (tptr t_struct_list) , _y OF (tptr t_struct_list)]
     PROP(writable_share sh)
     LOCAL (temp _x x; temp _y y)
     SEP (listrep sh s1 x; listrep sh s2 y)
  POST [ tptr t_struct_list ]
    EX r: val,
     PROP()
     LOCAL(temp ret_temp r)
     SEP (listrep sh (s1++s2) r).

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

Module Proof1.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null. normalize.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep at 1; fold listrep.
 normalize.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      ( EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP ()
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (listrep sh (a::s1b++s2) t -* listrep sh (s1++s2) x;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists v s1' x u.
   subst s1. entailer!. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1.
   destruct s1b; unfold listrep at 3; fold listrep. Intros. contradiction.
   Intros z.
   forward.
   forward.
   Exists (v,s1b,u0,z). unfold fst, snd.
   simpl app.
   entailer!.
   rewrite sepcon_comm.
   apply RAMIF_PLAIN.trans''.
   apply wand_sepcon_adjoint.
   forget (v::s1b++s2) as s3.
   unfold listrep; fold listrep; Exists u0; auto.
+ (* after the loop *)
   clear v s1' Heqs1.
   forward.
   forward.
   rewrite (proj1 H2 (eq_refl _)).
   Exists x.
   simpl app.
   clear.
   entailer!.
   unfold listrep at 3; fold listrep. normalize.
   pull_right (listrep sh (a :: s2) t -* listrep sh (s1 ++ s2) x).
   apply modus_ponens_wand'.
   unfold listrep at 2; fold listrep. Exists y; auto.
Qed.

End Proof1.

Module Proof2.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null. normalize.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep; fold listrep. Intros; contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val,  EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists (@nil val) v s1' x u.  entailer!.
   unfold lseg. apply allp_right; intro. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1. subst s1.
   destruct s1b; unfold listrep; fold listrep. Intros; contradiction.
   Intros z.
   forward.
   forward.
   Exists (s1a++[a],v,s1b,u0,z). unfold fst, snd.
   rewrite !app_ass. simpl app.
   entailer!.
   unfold lseg.
   rewrite sepcon_comm.
   clear.
   apply RAMIF_Q.trans'' with (cons a).
   extensionality cts; simpl; rewrite app_ass; reflexivity.
   apply allp_right; intro. apply wand_sepcon_adjoint.
   unfold listrep at 2; fold listrep; Exists u0.  apply derives_refl.
 + (* after the loop *)
   forward. forward.
   Exists x. entailer!.
   destruct H3 as [? _]. specialize (H3 (eq_refl _)). subst s1b.
   unfold listrep at 1. normalize. rewrite H0. rewrite app_ass. simpl app.
   unfold lseg.
   rewrite sepcon_assoc.
   eapply derives_trans; [apply allp_sepcon1 | ]. apply allp_left with (a::s2).
   rewrite sepcon_comm.
   eapply derives_trans; [ | apply modus_ponens_wand].
   apply sepcon_derives; [ | apply derives_refl].
   unfold listrep at 2; fold listrep. Exists y; auto.
Qed.

End Proof2.

Module Proof3.  (*************** inductive lseg *******************)

Fixpoint lseg (sh: share)
            (contents: list val) (x z: val) : mpred :=
 match contents with
 | h::hs => !! (x<>z) &&
              EX y:val,
                data_at sh t_struct_list (h,y) x * lseg sh hs y z
 | nil => !! (x = z /\ is_pointer_or_null x) && emp
 end.

Arguments lseg sh contents x z : simpl never.

Lemma lseg_local_facts:
  forall sh contents p q,
     lseg sh contents p q |--
     !! (is_pointer_or_null p /\ is_pointer_or_null q /\ (p=q <-> contents=nil)).
Proof.
intros.
apply derives_trans with (lseg sh contents p q && !! (is_pointer_or_null p /\
        is_pointer_or_null q /\ (p = q <-> contents = []))).
2: entailer!.
revert p; induction contents; intros; simpl; unfold lseg; fold lseg.
entailer!.
intuition.
Intros y. Exists y.
eapply derives_trans.
apply sepcon_derives.
apply derives_refl.
apply IHcontents.
entailer!.
intuition congruence.
Qed.

Hint Resolve lseg_local_facts : saturate_local.

Lemma lseg_valid_pointer:
  forall sh contents p ,
   sepalg.nonidentity sh ->
   lseg sh contents p nullval |-- valid_pointer p.
Proof.
 destruct contents; unfold lseg; fold lseg; intros; normalize;
 auto with valid_pointer.
Qed.

Hint Resolve lseg_valid_pointer : valid_pointer.

Lemma lseg_eq: forall sh contents x,
    lseg sh contents x x = !! (contents=nil /\ is_pointer_or_null x) && emp.
Proof.
intros.
destruct contents; unfold lseg; fold lseg.
f_equal. f_equal. f_equal. apply prop_ext; intuition.
normalize.
apply pred_ext.
Intros y. entailer.
Intros.
Qed.

Lemma lseg_null: forall sh contents,
    lseg sh contents nullval nullval = !! (contents=nil) && emp.
Proof.
intros.
 rewrite lseg_eq.
 apply pred_ext.
 entailer!.
 entailer!.
Qed.

Lemma lseg_cons: forall sh (v u x: val) s,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * lseg sh s u nullval
 |-- lseg sh [v] x u * lseg sh s u nullval.
Proof.
intros.
     unfold lseg at 2. Exists u.
     entailer.
     destruct s; unfold lseg at 1; fold lseg; entailer.
Qed.

Lemma lseg_cons': forall sh (v u x a b: val) ,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * data_at sh t_struct_list (a,b) u
 |-- lseg sh [v] x u * data_at sh t_struct_list (a,b) u.
Proof.
intros.
     unfold lseg. Exists u.
     entailer.
Qed.

Lemma lseg_app': forall sh s1 s2 (a w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * data_at sh t_struct_list (a,z) y |--
   lseg sh (s1++s2) w y * data_at sh t_struct_list (a,z) y.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app_null: forall sh s1 s2 (w x: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x nullval |--
   lseg sh (s1++s2) w nullval.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app: forall sh s1 s2 a s3 (w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * lseg sh (a::s3) y z |--
   lseg sh (s1++s2) w y * lseg sh (a::s3) y z.
Proof.
 intros.
 unfold lseg at 3 5; fold lseg.
 Intros u; Exists u. rewrite prop_true_andp by auto.
 sep_apply (lseg_app' sh s1 s2 a w x y u); auto.
 cancel.
Qed.

Lemma listrep_lseg_null :
 listrep = fun sh s p => lseg sh s p nullval.
Proof.
extensionality sh s p.
revert p.
induction s; intros.
unfold lseg, listrep; apply pred_ext; entailer!.
unfold lseg, listrep; fold lseg; fold listrep.
apply pred_ext; Intros y; Exists y; rewrite IHs; entailer!.
Qed.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
revert POSTCONDITION; rewrite listrep_lseg_null; intro.
forward_if.
*
 subst x. rewrite lseg_null. Intros. subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold lseg at 1; fold lseg.
 Intros. contradiction H.
 Intros u.
 clear - SH.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val, EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   lseg sh s1b u nullval;
                   lseg sh s2 y nullval))%assert.
 + (* current assertion implies loop invariant *)
     Exists (@nil val) v s1' x u.
     subst s1. rewrite lseg_eq.
     entailer.
(*     sep_apply (lseg_cons sh v u x s1'); auto. *)
 + (* loop test is safe to execute *)
     entailer!.
 + (* loop body preserves invariant *)
    destruct s1b; unfold lseg at 2; fold lseg.
    Intros. contradiction.
    Intros z.
    forward.
    forward.
    Exists (s1a++a::nil, v0, s1b,u0,z). unfold fst, snd.
    simpl app; rewrite app_ass.
    entailer.
    sep_apply (lseg_cons' sh a u0 t v0 z); auto.
    sep_apply (lseg_app' sh s1a [a] v0 x t u0 z); auto.
    cancel.
 + (* after the loop *)
    clear v s1' Heqs1.
    subst. rewrite lseg_eq. Intros. subst.
    forward.
    forward.
    Exists x.
    entailer!.
    sep_apply (lseg_cons sh a y t s2); auto.
    sep_apply (lseg_app_null sh [a] s2 t y); auto.
    rewrite app_ass.
    sep_apply (lseg_app_null sh s1a ([a]++s2) x t); auto.
Qed.

End Proof3.


From iris.bi Require Import big_op fixpoint.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import gmap auth agree gset coPset list.
From iris.program_logic Require Export total_weakestpre adequacy.
From iris Require Import options.
Import uPred.

Section adequacy.
Context `{!irisG Λ Σ}.
Implicit Types e : expr Λ.

Definition twptp_pre (twptp : list (expr Λ) → iProp Σ)
    (t1 : list (expr Λ)) : iProp Σ :=
  (∀ t2 σ1 κ κs σ2 n, ⌜step (t1,σ1) κ (t2,σ2)⌝ -∗
    state_interp σ1 κs n ={⊤}=∗ ∃ n', ⌜κ = []⌝ ∗ state_interp σ2 κs n' ∗ twptp t2)%I.

Lemma twptp_pre_mono (twptp1 twptp2 : list (expr Λ) → iProp Σ) :
  ⊢ <pers> (∀ t, twptp1 t -∗ twptp2 t) →
    ∀ t, twptp_pre twptp1 t -∗ twptp_pre twptp2 t.
Proof.
  iIntros "#H"; iIntros (t) "Hwp". rewrite /twptp_pre.
  iIntros (t2 σ1 κ κs σ2 n1) "Hstep Hσ".
  iMod ("Hwp" with "[$] [$]") as (n2) "($ & Hσ & ?)".
  iModIntro. iExists n2. iFrame "Hσ". by iApply "H".
Qed.

Local Instance twptp_pre_mono' : BiMonoPred twptp_pre.
Proof.
  constructor; first apply twptp_pre_mono.
  intros wp Hwp n t1 t2 ?%(discrete_iff _ _)%leibniz_equiv; solve_proper.
Qed.

Definition twptp (t : list (expr Λ)) : iProp Σ :=
  bi_least_fixpoint twptp_pre t.

Lemma twptp_unfold t : twptp t ⊣⊢ twptp_pre twptp t.
Proof. by rewrite /twptp least_fixpoint_unfold. Qed.

Lemma twptp_ind Ψ :
  ⊢ (□ ∀ t, twptp_pre (λ t, Ψ t ∧ twptp t) t -∗ Ψ t) → ∀ t, twptp t -∗ Ψ t.
Proof.
  iIntros "#IH" (t) "H".
  assert (NonExpansive Ψ).
  { by intros n ?? ->%(discrete_iff _ _)%leibniz_equiv. }
  iApply (least_fixpoint_strong_ind _ Ψ with "[] H").
  iIntros "!>" (t') "H". by iApply "IH".
Qed.

Instance twptp_Permutation : Proper ((≡ₚ) ==> (⊢)) twptp.
Proof.
  iIntros (t1 t1' Ht) "Ht1". iRevert (t1' Ht); iRevert (t1) "Ht1".
  iApply twptp_ind; iIntros "!>" (t1) "IH"; iIntros (t1' Ht).
  rewrite twptp_unfold /twptp_pre. iIntros (t2 σ1 κ κs σ2 n Hstep) "Hσ".
  destruct (step_Permutation t1' t1 t2 κ σ1 σ2) as (t2'&?&?); [done..|].
  iMod ("IH" $! t2' with "[% //] Hσ") as (n2) "($ & Hσ & IH & _)".
  iModIntro. iExists n2. iFrame "Hσ". by iApply "IH".
Qed.

Lemma twptp_app t1 t2 : twptp t1 -∗ twptp t2 -∗ twptp (t1 ++ t2).
Proof.
  iIntros "H1". iRevert (t2). iRevert (t1) "H1".
  iApply twptp_ind; iIntros "!>" (t1) "IH1". iIntros (t2) "H2".
  iRevert (t1) "IH1"; iRevert (t2) "H2".
  iApply twptp_ind; iIntros "!>" (t2) "IH2". iIntros (t1) "IH1".
  rewrite twptp_unfold /twptp_pre. iIntros (t1'' σ1 κ κs σ2 n Hstep) "Hσ1".
  destruct Hstep as [e1 σ1' e2 σ2' efs' t1' t2' [=Ht ?] ? Hstep]; simplify_eq/=.
  apply app_eq_inv in Ht as [(t&?&?)|(t&?&?)]; subst.
  - destruct t as [|e1' ?]; simplify_eq/=.
    + iMod ("IH2" with "[%] Hσ1") as (n2) "($ & Hσ & IH2 & _)".
      { by eapply step_atomic with (t1:=[]). }
      iModIntro. iExists n2. iFrame "Hσ".
      rewrite -{2}(left_id_L [] (++) (e2 :: _)). iApply "IH2".
      by setoid_rewrite (right_id_L [] (++)).
    + iMod ("IH1" with "[%] Hσ1") as (n2) "($ & Hσ & IH1 & _)"; first by econstructor.
      iAssert (twptp t2) with "[IH2]" as "Ht2".
      { rewrite twptp_unfold. iApply (twptp_pre_mono with "[] IH2").
        iIntros "!> * [_ ?] //". }
      iModIntro. iExists n2. iFrame "Hσ".
      rewrite -assoc_L (comm _ t2) !cons_middle !assoc_L. by iApply "IH1".
  - iMod ("IH2" with "[%] Hσ1") as (n2) "($ & Hσ & IH2 & _)"; first by econstructor.
    iModIntro. iExists n2. iFrame "Hσ". rewrite -assoc_L. by iApply "IH2".
Qed.

Lemma twp_twptp s Φ e : WP e @ s; ⊤ [{ Φ }] -∗ twptp [e].
Proof.
  iIntros "He". remember (⊤ : coPset) as E eqn:HE.
  iRevert (HE). iRevert (e E Φ) "He". iApply twp_ind.
  iIntros "!>" (e E Φ); iIntros "IH" (->).
  rewrite twptp_unfold /twptp_pre /twp_pre. iIntros (t1' σ1' κ κs σ2' n Hstep) "Hσ1".
  destruct Hstep as [e1 σ1 e2 σ2 efs [|? t1] t2 ?? Hstep];
    simplify_eq/=; try discriminate_list.
  destruct (to_val e1) as [v|] eqn:He1.
  { apply val_stuck in Hstep; naive_solver. }
  iMod ("IH" with "Hσ1") as "[_ IH]".
  iMod ("IH" with "[% //]") as "($ & Hσ & [IH _] & IHfork)".
  iModIntro. iExists (length efs + n). iFrame "Hσ".
  iApply (twptp_app [_] with "(IH [//])").
  clear. iInduction efs as [|e efs] "IH"; simpl.
  { rewrite twptp_unfold /twptp_pre. iIntros (t2 σ1 κ κs σ2 n1 Hstep).
    destruct Hstep; simplify_eq/=; discriminate_list. }
  iDestruct "IHfork" as "[[IH' _] IHfork]".
  iApply (twptp_app [_] with "(IH' [//])"). by iApply "IH".
Qed.

Lemma twptp_total n σ t :
  state_interp σ [] n -∗ twptp t ={⊤}=∗ ▷ ⌜sn erased_step (t, σ)⌝.
Proof.
  iIntros "Hσ Ht". iRevert (σ n) "Hσ". iRevert (t) "Ht".
  iApply twptp_ind; iIntros "!>" (t) "IH"; iIntros (σ n) "Hσ".
  iApply (pure_mono _ _ (Acc_intro _)). iIntros ([t' σ'] [κ Hstep]).
  rewrite /twptp_pre.
  iMod ("IH" with "[% //] Hσ") as (n' ->) "[Hσ [H _]]".
  by iApply "H".
Qed.
End adequacy.

Theorem twp_total Σ Λ `{!invPreG Σ} s e σ Φ :
  (∀ `{Hinv : !invG Σ},
     ⊢ |={⊤}=> ∃
         (stateI : state Λ → list (observation Λ) → nat → iProp Σ)
         (fork_post : val Λ → iProp Σ),
       let _ : irisG Λ Σ := IrisG _ _ Hinv stateI fork_post in
       stateI σ [] 0 ∗ WP e @ s; ⊤ [{ Φ }]) →
  sn erased_step ([e], σ). (* i.e. ([e], σ) is strongly normalizing *)
Proof.
  intros Hwp. apply (soundness (M:=iResUR Σ) _  1); simpl.
  apply (fupd_plain_soundness ⊤ ⊤ _)=> Hinv.
  iMod (Hwp) as (stateI fork_post) "[Hσ H]".
  iApply (@twptp_total _ _ (IrisG _ _ Hinv stateI fork_post) with "Hσ").
  by iApply (@twp_twptp _ _ (IrisG _ _ Hinv stateI fork_post)).
Qed.


Require Import Frap Pset11Sig.

(* Opaque mtree. *)
(* ^-- Don't forget to mark predicates opaque after you've finished proving
 * all the key algebraic properties about them, in order for them to work
 * well with the [cancel] tactic. *)

Theorem lookup_ok : forall x p,
  {{mtreep p}}
    lookup x p
  {{_ ~> mtreep p}}.
Proof.
Admitted.

Theorem insert_ok : forall x p,
  {{mtreep p}}
    insert x p
  {{_ ~> mtreep p}}.
Proof.
Admitted.