(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
(** This file defines the core logic (called [mpred]) that we use
    for C++.

    Known issues:
    - currently the logic is sequentially consistent
    - the memory model is simplified from the standard C++ memory
      model.
 *)
Require Export bedrock.prelude.addr.

From bedrock.lang.bi Require Export prelude observe.
From bedrock.lang.cpp.logic Require Export mpred rep.
(** ^^ Delicate; export types and canonical structures (CS) for [monPred], [mpred] and [Rep].
Export order can affect CS inference. *)

From bedrock.lang.cpp.algebra Require Export cfrac.
Require Export bedrock.lang.cpp.bi.cfractional.

From iris.base_logic.lib Require Export iprop.
(* TODO: ^^ only needed to export uPredI, should be removed. *)
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import proofmode.

Require Import bedrock.lang.bi.na_invariants.
Require Import bedrock.lang.bi.cancelable_invariants.
Export ChargeNotation.

From bedrock.lang.cpp.syntax Require Import
     names
     types
     translation_unit.
From bedrock.lang.cpp.semantics Require Import values subtyping.

#[local] Set Printing Coercions.

Variant validity_type : Set := Strict | Relaxed.

Implicit Types (vt : validity_type) (σ resolve : genv).
Implicit Types (n : N) (z : Z).

(* Namespace for the invariants of the C++ abstraction's ghost state. *)
Definition pred_ns : namespace := nroot .@@ "bedrock" .@@ "lang" .@@ "cpp_logic".

Module Type CPP_LOGIC
  (Import P : PTRS_INTF)
  (Import INTF : VALUES_INTF_FUNCTOR P)
  (Import CC : CPP_LOGIC_CLASS).

  Implicit Types (p : ptr).

  Section with_cpp.
    Context `{Σ : cpp_logic}.

    (**
      [_valid_ptr vt p] is a persistent assertion that [p] is a _valid pointer_, that is:
      - [p] can point to a function or a (possibly dead) object [o]
      - if [vt = Relaxed], [p] can be nullptr, or past-the-end of a (possibly dead) object [o].
      In particular, [_valid_ptr vt p] prevents producing [p] by incrementing
      past-the-end pointers into overflow territory.

      Our definition of validity includes all cases in which a pointer is not
      an _invalid pointer value_ in the sense of the standard
      (https://eel.is/c++draft/basic.compound#3.1), except that our concept
      of validity survives deallocation; a pointer is only valid according to
      the standard (or "standard-valid") if it is _both_ valid ([_valid_ptr
      vt p]) and live ([live_ptr p]); we require both where needed (e.g.
      [eval_ptr_eq]).

      When the duration of a region of storage ends [note 1], contained objects [o] go
      from live to dead, and pointers to such objects become _dangling_, or
      _invalid pointer values_ (https://eel.is/c++draft/basic.compound#3.1);
      this is called _pointer zapping_ [note 1].
      In our semantics, that only consumes the non-persistent predicate
      [live_ptr p], not the persistent predicate [_valid_ptr vt p].

      Following Cerberus, [live_alloc_id] tracks liveness per allocation
      ID (see comments for [ptr]), and [live_ptr] is derived from it. Hence,
      a pointer [p] past-the-end of [o] also becomes dangling when [o] is
      deallocated.

      It's implementation-defined whether invalid pointer values are
      (non-copyable) trap representations. Instead, we restrict to
      implementations where dangling pointers are not trap representations
      (which is allowed, since this choice is implementation-defined) and
      pointer zapping does not actually clear pointers.

      [Note 1]. See https://eel.is/c++draft/basic.stc.general#4 and
      https://eel.is/c++draft/basic.compound#3.1 for C++, and
      http://www.open-std.org/jtc1/sc22/wg14/www/docs/n2369.pdf for
      discussion in the context of the C standard.
    *)
    Parameter _valid_ptr : forall (vt : validity_type), ptr -> mpred.
    (* strict validity (not past-the-end) *)
    Notation strict_valid_ptr := (_valid_ptr Strict).
    (* validity (past-the-end allowed) *)
    Notation valid_ptr := (_valid_ptr Relaxed).

    Axiom _valid_ptr_persistent : forall b p, Persistent (_valid_ptr b p).
    Axiom _valid_ptr_affine : forall b p, Affine (_valid_ptr b p).
    Axiom _valid_ptr_timeless : forall b p, Timeless (_valid_ptr b p).
    #[global] Existing Instances _valid_ptr_persistent _valid_ptr_affine _valid_ptr_timeless.

    Axiom valid_ptr_nullptr : |-- valid_ptr nullptr.
    Axiom not_strictly_valid_ptr_nullptr : strict_valid_ptr nullptr |-- False.
    Axiom strict_valid_valid : forall p,
      strict_valid_ptr p |-- valid_ptr p.

    (** Formalizes the notion of "provides storage",
    http://eel.is/c++draft/intro.object#def:provides_storage *)
    Parameter provides_storage :
      forall (storage : ptr) (object : ptr) (object_type : type), mpred.

    Axiom provides_storage_persistent :
      forall storage_ptr obj_ptr ty,
      Persistent (provides_storage storage_ptr obj_ptr ty).
    Axiom provides_storage_affine :
      forall storage_ptr obj_ptr ty,
      Affine (provides_storage storage_ptr obj_ptr ty).
    Axiom provides_storage_timeless :
      forall storage_ptr obj_ptr ty,
      Timeless (provides_storage storage_ptr obj_ptr ty).
    #[global] Existing Instances provides_storage_persistent provides_storage_affine provides_storage_timeless.

    (**
    Typed points-to predicate. Fact [tptsto t q p v] asserts the following things:
    1. Pointer [p] points to value [v].
    2. We have fractional ownership [q] (in the separation logic sense).
    3. Pointer [p] points to a memory location with C++ type [t].
    However:
    1. Value [v] need not be initialized.
    2. Hence, [v] might not satisfy [has_type t v].

    We use this predicate both for pointers to actual memory and for pointers to
    C++ locations that are not stored in memory (as an optimization).
    *)
    Parameter tptsto : forall {σ:genv} (t : type) (q : cQp.t) (a : ptr) (v : val), mpred.

    Axiom tptsto_nonnull : forall {σ} ty q a,
      @tptsto σ ty q nullptr a |-- False.

    Axiom tptsto_proper :
      Proper (genv_eq ==> eq ==> eq ==> eq ==> eq ==> (≡)) (@tptsto).
    Axiom tptsto_mono :
      Proper (genv_leq ==> eq ==> eq ==> eq ==> eq ==> (⊢)) (@tptsto).
    #[global] Existing Instances tptsto_proper tptsto_mono.

    #[global] Declare Instance tptsto_timeless : Timeless5 (@tptsto).
    #[global] Declare Instance tptsto_cfractional {σ} ty : CFractional2 (tptsto ty).

    #[global] Declare Instance tptsto_cfrac_valid {σ} t : CFracValid2 (tptsto t).

    Axiom tptsto_agree : forall {σ} ty q1 q2 p v1 v2,
      Observe2 [| val_related σ ty v1 v2 |]
               (@tptsto σ ty q1 p v1)
               (@tptsto σ ty q2 p v2).
    #[global] Existing Instances tptsto_agree.

    (* TODO (JH/PG): Add in a proper instance using this which allows us to rewrite
         `val_related` values within `tptsto`s.

         <https://gitlab.com/bedrocksystems/cpp2v-core/-/merge_requests/377#note_530611061> *)
    Axiom tptsto_val_related_transport : forall {σ} ty q p v1 v2,
        [| val_related σ ty v1 v2 |] |-- @tptsto σ ty q p v1 -* @tptsto σ ty q p v2.

    (** The allocation is alive. Neither persistent nor fractional.
      See https://eel.is/c++draft/basic.stc.general#4 and
      https://eel.is/c++draft/basic.compound#3.1.
    *)
    Parameter live_alloc_id : alloc_id -> mpred.
    Axiom live_alloc_id_timeless : forall aid, Timeless (live_alloc_id aid).
    #[global] Existing Instance live_alloc_id_timeless.

    Axiom valid_ptr_alloc_id : forall p,
      valid_ptr p |-- [| is_Some (ptr_alloc_id p) |].

    (** This pointer is from a live allocation; this does not imply
    [_valid_ptr], because even overflowing offsets preserve the allocation ID.
    *)
    Definition live_ptr (p : ptr) :=
      default False%I (live_alloc_id <$> ptr_alloc_id p).

    (** We consider [nullptr] as live, following Krebbers, as a way to
    simplify stating rules for pointer comparison. *)
    Axiom nullptr_live : |-- live_ptr nullptr.

    Axiom tptsto_live : forall {σ} ty (q : cQp.t) p v,
      @tptsto σ ty q p v |-- live_ptr p ** True.

    (** [identity σ this mdc q p] state that [p] is a pointer to a (live)
        object of type [this] that is part of an object that can be reached
        using the *path* [mdc].
        - if [mdc = []] then this object identity is not initialized yet,
          e.g. because its base classes are still being constructed.
        - otherwise, [mdc] is the *path* from the most derived class to this
          object. For example, suppose you have:
          ```c++
          struct A { virtual int f() { return 0; } };
          struct B : public A { virtual int f() { return 1; } };
          struct C : public A { };
          struct D : public B, public C {};

          int doA(A* a) { return a->f(); }
          int test() {
              D d;
              return doA(static_cast<B*>(&d)) /* = 1 */
                   + doA(static_cast<C*>(&d)) /* = 0 */;
          }
          ```
          for a fully constructed object of type `D` (at pointer [d]), you would
          have:
          [[
          identity "::D" ["::D"]           1  d **
          identity "::B" ["::D","::B"]      1 (d ., _base "::B") **
          identity "::A" ["::D","::B","::A"] 1 (d ,, _base "::B" ,, _base "::A") **
          identity "::C" ["::D","::C"]      1 (d ,, _base "::C") **
          idenitty "::A" ["::D","::C","::A"] 1 (d ,, _base "::C" ,, _base "::A")
          ]]
          in the partially constructed state, where "::D" has not yet been constructed
          but the base classes have been, you have the following:
          [[
          identity "::B" ["::B"]      1 (d ., _base "::B") **
          identity "::A" ["::B","::A"] 1 (d ,, _base "::B" ,, _base "::A") **
          identity "::C" ["::C"]      1 (d ,, _base "::C") **
          idenitty "::A" ["::C","::A"] 1 (d ,, _base "::C" ,, _base "::A")
          ]]
          note that you do not get [identity "::D" [] 1 d] at this point, you
          get [identity "::D" ["::D"] 1 d] when you update all the other identities
          (but not atomically)

        [identity] is primarily used to dispatch virtual function calls.

        compilers can use the ownership here to represent dynamic dispatch
        tables.
     *)
    Parameter identity : forall {σ : genv}
        (this : globname) (most_derived : list globname),
        cQp.t -> ptr -> mpred.
    #[global] Declare Instance identity_cfractional σ this mdc : CFractional1 (identity this mdc).
    #[global] Declare Instance identity_cfrac_valid {σ} cls path : CFracValid1 (identity cls path).
    #[global] Declare Instance identity_timeless : Timeless5 (@identity).
    #[global] Declare Instance identity_strict_valid σ this mdc q p : Observe (strict_valid_ptr p) (identity this mdc q p).

    (** cpp2v-core#194: Agreement? *)

    (** this allows you to forget an object identity, necessary for doing
        placement [new] over an existing object.
     *)
    Axiom identity_forget : forall σ mdc this p,
        @identity σ this mdc (cQp.m 1) p |-- |={↑pred_ns}=> @identity σ this nil (cQp.m 1) p.

    (** the pointer points to the code

      note that in the presence of code-loading, function calls will
      require an extra side-condition that the code is loaded.
     *)
    Parameter code_at : genv -> translation_unit -> Func -> ptr -> mpred.
    Parameter method_at : genv -> translation_unit -> Method -> ptr -> mpred.
    Parameter ctor_at : genv -> translation_unit -> Ctor -> ptr -> mpred.
    Parameter dtor_at : genv -> translation_unit -> Dtor -> ptr -> mpred.

    Section with_genv.
      Context {σ : genv} (tu : translation_unit).
      #[local] Notation code_at := (code_at σ tu) (only parsing).
      #[local] Notation method_at := (method_at σ tu) (only parsing).
      #[local] Notation ctor_at := (ctor_at σ tu) (only parsing).
      #[local] Notation dtor_at := (dtor_at σ tu) (only parsing).

      Axiom code_at_persistent : forall f p, Persistent (code_at f p).
      Axiom code_at_affine : forall f p, Affine (code_at f p).
      Axiom code_at_timeless : forall f p, Timeless (code_at f p).

      Axiom method_at_persistent : forall f p, Persistent (method_at f p).
      Axiom method_at_affine : forall f p, Affine (method_at f p).
      Axiom method_at_timeless : forall f p, Timeless (method_at f p).

      Axiom ctor_at_persistent : forall f p, Persistent (ctor_at f p).
      Axiom ctor_at_affine : forall f p, Affine (ctor_at f p).
      Axiom ctor_at_timeless : forall f p, Timeless (ctor_at f p).

      Axiom dtor_at_persistent : forall f p, Persistent (dtor_at f p).
      Axiom dtor_at_affine : forall f p, Affine (dtor_at f p).
      Axiom dtor_at_timeless : forall f p, Timeless (dtor_at f p).

      #[global] Existing Instances
        code_at_persistent code_at_affine code_at_timeless
        method_at_persistent method_at_affine method_at_timeless
        ctor_at_persistent ctor_at_affine ctor_at_timeless
        dtor_at_persistent dtor_at_affine dtor_at_timeless.

      Axiom code_at_live   : forall f p,   code_at f p |-- live_ptr p.
      Axiom method_at_live : forall f p, method_at f p |-- live_ptr p.
      Axiom ctor_at_live   : forall f p,   ctor_at f p |-- live_ptr p.
      Axiom dtor_at_live   : forall f p,   dtor_at f p |-- live_ptr p.

      Axiom code_at_strict_valid   : forall f p,   code_at f p |-- strict_valid_ptr p.
      Axiom method_at_strict_valid : forall f p, method_at f p |-- strict_valid_ptr p.
      Axiom ctor_at_strict_valid   : forall f p,   ctor_at f p |-- strict_valid_ptr p.
      Axiom dtor_at_strict_valid   : forall f p,   dtor_at f p |-- strict_valid_ptr p.

    End with_genv.

    Axiom offset_pinned_ptr_pure : forall σ o z va p,
      eval_offset σ o = Some z ->
      ptr_vaddr p = Some va ->
      valid_ptr (p ,, o) |--
      [| ptr_vaddr (p ,, o) = Some (Z.to_N (Z.of_N va + z)) |].

    Axiom offset_inv_pinned_ptr_pure : forall σ o z va p,
      eval_offset σ o = Some z ->
      ptr_vaddr (p ,, o) = Some va ->
      valid_ptr (p ,, o) |--
      [| 0 <= Z.of_N va - z |]%Z **
      [| ptr_vaddr p = Some (Z.to_N (Z.of_N va - z)) |].

    Axiom provides_storage_same_address : forall storage_ptr obj_ptr ty,
      Observe [| same_address storage_ptr obj_ptr |] (provides_storage storage_ptr obj_ptr ty).

    Axiom provides_storage_valid_storage_ptr : forall storage_ptr obj_ptr aty,
      Observe (valid_ptr storage_ptr) (provides_storage storage_ptr obj_ptr aty).
    Axiom provides_storage_valid_obj_ptr : forall storage_ptr obj_ptr aty,
      Observe (valid_ptr obj_ptr) (provides_storage storage_ptr obj_ptr aty).

    #[global] Existing Instances provides_storage_same_address
      provides_storage_valid_storage_ptr provides_storage_valid_obj_ptr.

    (**
    [exposed_aid aid] states that the storage instance identified by [aid] is
    "exposed" [1]. This enables int2ptr casts to produce pointers into this
    storage instance.

    [1] We use "exposed" in the sense defined by the N2577 draft C standard
    (http://www.open-std.org/jtc1/sc22/wg14/www/docs/n2577.pdf).
    See https://dl.acm.org/doi/10.1145/3290380 for an introduction.
    *)
    Parameter exposed_aid : alloc_id -> mpred.
    Axiom exposed_aid_persistent : forall aid, Persistent (exposed_aid aid).
    Axiom exposed_aid_affine : forall aid, Affine (exposed_aid aid).
    Axiom exposed_aid_timeless : forall aid, Timeless (exposed_aid aid).

    Axiom exposed_aid_null_alloc_id : |-- exposed_aid null_alloc_id.

    #[global] Existing Instances
      exposed_aid_persistent exposed_aid_affine exposed_aid_timeless.

    (**
      [type_ptr {resolve := resolve} ty p] asserts that [p] points to
      a (possibly dead) object of type [ty] (in environment
      [resolve]), as defined by https://eel.is/c++draft/basic.compound#3.1.

      This implies:
      - the pointer is strictly valid [type_ptr_strict_valid], and
        "p + 1" is also valid (while possibly past-the-end) [type_ptr_valid_plus_one].
      - the pointer is not (an offset of) null pointers [type_ptr_off_nonnull, type_ptr_nonnull]
      - the pointer is properly aligned [type_ptr_aligned_pure]

      [type_ptr] is persistent and survives deallocation of the pointed-to
      object, like [_valid_ptr].

      TODO: before a complete object is fully initialized,
      what [type_ptr] facts are available? For now, we only use [type_ptr]
      for fully initialized objects.
      Consider http://eel.is/c++draft/basic.memobj#basic.life, especially
      from http://eel.is/c++draft/basic.memobj#basic.life-1 to
      http://eel.is/c++draft/basic.memobj#basic.life-4.
     *)
    Parameter type_ptr : forall {resolve : genv} (c: type), ptr -> mpred.
    Axiom type_ptr_persistent : forall σ p ty,
      Persistent (type_ptr ty p).
    Axiom type_ptr_affine : forall σ p ty,
      Affine (type_ptr ty p).
    Axiom type_ptr_timeless : forall σ p ty,
      Timeless (type_ptr ty p).
    #[global] Existing Instances type_ptr_persistent type_ptr_affine type_ptr_timeless.

    Axiom type_ptr_aligned_pure : forall σ ty p,
      type_ptr ty p |-- [| aligned_ptr_ty ty p |].

    Axiom type_ptr_off_nonnull : forall {σ ty p o},
      type_ptr ty (p ,, o) |-- [| p <> nullptr |].

    Axiom tptsto_type_ptr : forall (σ : genv) ty q p v,
      Observe (type_ptr ty p) (tptsto ty q p v).
    #[global] Existing Instance tptsto_type_ptr.

    (* All objects in the C++ abstract machine have a size

       NOTE to support un-sized objects, we can simply say that the [sizeof] operator
            in C++ is only a conservative approximation of the true size of an object.
     *)
    Axiom type_ptr_size : forall σ ty p,
        type_ptr ty p |-- [| is_Some (size_of σ ty) |].

    (**
    Recall that [type_ptr] and [strict_valid_ptr] don't include
    past-the-end pointers... *)
    Axiom type_ptr_strict_valid : forall resolve ty p,
      type_ptr ty p |-- strict_valid_ptr p.
    (** Hence they can be incremented into (possibly past-the-end) valid pointers. *)
    Axiom type_ptr_valid_plus_one : forall resolve ty p,
      type_ptr ty p |-- valid_ptr (p ,, o_sub resolve ty 1).

    (* When [p] is a [ptr] to a C++ object of type [ty], [p] is /also/ a pointer
       to the "object representation" of [ty] - which consists of "the sequence
       of [sizeof(ty)] unsigned char objects taken up by the object of
       type [ty]" [1].

       Detailed Justification:
       a) From the comment above the axiomatization of [type_ptr]:
          | [type_ptr ty p] asserts that [p] points to a (possibly dead) object of type [ty].
       b) In [basic.types.general#4] [1] the C++ Standard states that:
          | The object representation of an object of type T is the sequence of N unsigned
          | char objects taken up by the object of type T, where N equals sizeof(T).
       d) (NOTE: the C++ Standard lacks language regarding this point) the "object representation"
          for an object pointed to by [ptr] [p] is /also/ accessible via [p].
       e) (a)+(b)+(d) implies that a (potentially dead) object representation for type [ty]
          exists at [ptr] [p]
       f) (a)+(c)+(e) implies that [type_ptr Tu8 (p .[ Tu8 ! i ])] holds (regardless of whether
          not the object/"object representation" is alive)

       NOTE: There is no need to deal with past-the-end pointers explicitly since
       [type_ptr] explicitly excludes them; validity of past-the-end pointers
       can be established using [type_ptr_valid_plus_one].

       [1] <https://eel.is/c++draft/basic.types.general#4>
     *)
    Section type_ptr_object_representation.
      (* This section is intended to axiomatize a /sufficient/ and /sound/
         set of transport rules for [type_ptr] facts which can be used to
         satisfy the preconditions required when using [ptr_congP] to
         transport other resources.
       *)

      (* The following [Axiom] reflects a trivially faithful encoding of
         the quote from the C++ standard above [Section type_ptr_object_representation].

         NOTE: To practically use this [Axiom], [type_ptr] must be [Persistent];
         a reasonable alternative axiomatization which sidestepts this issue
         could produce /all/ of the [type_ptr] facts for the "object representation"
         at once:
         | ... ->
         |     type_ptr ty p
         | |-- [∗list] i ∈ seqN 0 (sizeof ty), type_ptr Tu8 (p .[ Tu8 ! i ])
       *)
      Section conservative.
        Axiom type_ptr_obj_repr_byte :
          forall (σ : genv) (ty : type) (p : ptr) (i sz : N),
            size_of σ ty = Some sz -> (* 1) [ty] has some byte-size [sz] *)
            (i < sz)%N ->             (* 2) by (1), [sz] is nonzero and [i] is a
                                            byte-offset into the object rooted at [p ,, o]

                                         NOTE: [forall ty, size_of (Tarray ty 0) = Some 0],
                                         but zero-length arrays are not permitted by the Standard
                                         (cf. <https://eel.is/c++draft/dcl.array#def:array,bound>).
                                         NOTE: if support for flexible array members is ever added,
                                         it will need to be carefully coordinated with these sorts
                                         of transport lemmas.
                                       *)
            (* 4) The existence of the "object representation" of an object of type [ty] -
               |  in conjunction with the premises - justifies "lowering" any
               |  [type_ptr ty p] fact to a collection of [type_ptr Tu8 (p ,, .[Tu8 ! i])]
               |  facts - where [i] is a byte-offset within the [ty] ([0 <= i < sizeof(ty)]).
               v *)
            type_ptr ty p |-- type_ptr Tu8 (p ,, .[ Tu8 ! i ]).
      End conservative.

      (* NOTE: This might be reasonable to axiomatize directly; cf. the [NOTE] above
         [Section conservative].
       *)
      Section all_at_once.
        Lemma type_ptr_obj_repr :
          forall (σ : genv) (ty : type) (p : ptr) (sz : N),
            size_of σ ty = Some sz ->
            type_ptr ty p |-- [∗list] i ∈ seqN 0 sz, type_ptr Tu8 (p .[ Tu8 ! Z.of_N i ]).
        Proof.
          intros * Hsz; iIntros "#tptr".
          iApply big_sepL_intro; iIntros "!>" (k n) "%Hn'".
          assert (lookup (K:=N) (N.of_nat k) (seqN 0%N sz) = Some n)
            as Hn
            by (unfold lookupN, list_lookupN; rewrite Nat2N.id //);
            clear Hn'.
          apply lookupN_seqN in Hn as [? ?].
          iDestruct (type_ptr_obj_repr_byte σ ty p n sz Hsz ltac:(lia) with "tptr") as "$".
        Qed.
      End all_at_once.
    End type_ptr_object_representation.

    (* [offset_congP] hoists [offset_cong] to [mpred] *)
    Definition offset_congP (σ : genv) (o1 o2 : offset) : mpred :=
      [| offset_cong σ o1 o2 |].

    (* [ptr_congP σ p1 p2] is an [mpred] which quotients [ptr_cong σ p1 p2]
       by requiring that [type_ptr Tu8] holds for both [p1] /and/ [p2]. This property
       is intended to be sound and sufficient for transporting certain physical
       resources between [p1] and [p2] - and we hypothesize that it is also
       necessary.
     *)
    Definition ptr_congP (σ : genv) (p1 p2 : ptr) : mpred :=
      [| ptr_cong σ p1 p2 |] ** type_ptr Tu8 p1 ** type_ptr Tu8 p2.

    (* All [tptsto Tu8] facts can be transported over [ptr_congP] [ptr]s.

       High level meaning:
       In the C++ object model, a single byte of storage can be accessed through different pointers,
       e.g. consider [struct C { int x; int y; } c;]. The first byte of the struct can be read through
       [static_cast<byte*>(&c)] (with pointer representation [c]) as well as [static_cast<byte*>(&c.x)]
       (with pointer representation [c ,, _field "::C" "x"]). To put an ownership discipline on this
       single byte, we build an equivalence relation on pointers that allows us to transport ownership
       of the byte between these different pointers. For example, half of the ownership could live at [c]
       and the other half of the ownership can live at [c ,, _field "::C" "x"].

       The standard justifies this as follows:
       1) (cf. [tptsto] comment) [tptsto ty q p v] ensures that [p] points to a memory
          location with C++ type [ty] and which has some value [v].
       2) (cf. [Section type_ptr_object_representation]) [type_ptr Tu8] holds for all of the
          bytes (i.e. the "object reprsentation") constituting well-typed C++ objects.
       3) NOTE (JH): the following isn't quite true yet, but we'll want this when we flesh
          out [rawR]/[RAW_BYTES]:
          a) all values [v] can be converted into (potentially many) [raw_byte]s -
             which capture its "object representation"
          b) all [tptsto ty] facts can be shattered into (potentially many)
             [tptsto Tu8 _ _ (Vraw _)] facts corresponding to its "object representation"
       4) [tptsto Tu8 _ _ (Vraw _)] can be transported over [ptr_congP] [ptr]s:
          a) [tptso Tu8 _ _ (Vraw _)] facts deal with the "object representation" directly
             and thus permit erasing the structure of pointers in favor of reasoning about
             relative byte offsets from a shared [ptr]-prefix.
          b) the [ptr]s are [ptr_congP] so we know that:
             i) they share a common base pointer [p_base]
             ii) the byte-offset values of the C++ offsets which reconstitute the src/dst from
                 [p_base] are equal
             iii) NOTE: (cf. [valid_ptr_nonnull_nonzero]/[type_ptr_valid_ptr]/[type_ptr_nonnull] below)
                  [p_base] has some [vaddr], but we don't currently rely on this fact.
     *)
    (* TODO: improve our axiomatic support for raw values - including "shattering"
       non-raw values into their constituent raw pieces - to enable deriving
       [tptsto_ptr_congP_transport] from [tptsto_raw_ptr_congP_transport].
     *)
    Axiom tptsto_ptr_congP_transport : forall {σ} q p1 p2 v,
      ptr_congP σ p1 p2 |-- @tptsto σ Tu8 q p1 v -* @tptsto σ Tu8 q p2 v.

    (**
     ** Deducing pointer equalities
     The following axioms, together with [same_address_o_sub_eq], enable going
     from [same_address] (produced by C++ pointer equality) to actual pointer
     equalities.
     *)

    (** Pointer equality with [nullptr] is easy, as long as your pointer is valid.
     Validity is necessary: the C++ expression [(char * )p - (uintptr_t) p]
     produces an invalid pointer with address 0, which is not [nullptr] because
     it preserves the provenance of [p]. *)
    Axiom same_address_eq_null : forall p tv,
      _valid_ptr tv p |--
      [| same_address p nullptr <-> p = nullptr |].

    (**
    [same_address_eq_type_ptr] concludes that two pointers [p1] and [p2] are
    equal if they have the same address, point to live objects [o1] and [o2],
    and have the same (non-uchar) type [ty] with nonzero size.

    Justifying this from the standard is tricky; here's a proof sketch.
    - Because [ty] has "nonzero size" (https://eel.is/c++draft/intro.object#8),
      and we don't support bitfields, we apply the standard:

      > Unless it is a bit-field, an object with nonzero size shall occupy one
        or more bytes of storage, including every byte that is occupied in full
        or in part by any of its subobjects.

    - Because [o1] and [o2] are live, these objects share storage, hence they
      must coincide or one must be nested inside the other
      (https://eel.is/c++draft/intro.object#4); if they coincide, our proof
      is done.
    - Because [ty] is not [unsigned char], neither pointer can provide storage
      for the other (https://eel.is/c++draft/intro.object#3); so one must be a
      subobject of the other.
    - Since [o1] and [o2] have type [ty], and type [ty] has "nonzero size",
      neither of [o1] and [o2] can be a subobject of the other;
      we conjecture is provable from the C++ type system.

    NOTE: we check "nonzero size"
    (https://eel.is/c++draft/basic.memobj#intro.object-8) using [size_of],
    which might incorporate implementation-specific compiler decisions.
    TODO: handle [std::byte] like [unsigned char].
    *)
    Axiom same_address_eq_type_ptr : forall resolve ty p1 p2 n,
      same_address p1 p2 ->
      size_of resolve ty = Some n ->
      (* if [ty = Tuchar], one of these pointer could provide storage for the other. *)
      ty <> Tuchar ->
      (n > 0)%N ->
      type_ptr ty p1 ∧ type_ptr ty p2 ∧ live_ptr p1 ∧ live_ptr p2 ⊢
        |={↑pred_ns}=> [| p1 = p2 |].
  End with_cpp.

  (* strict validity (not past-the-end) *)
  Notation strict_valid_ptr := (_valid_ptr Strict).
  (* validity (past-the-end allowed) *)
  Notation valid_ptr := (_valid_ptr Relaxed).
End CPP_LOGIC.

(* Pointer axioms. XXX Not modeled for now. *)
Module Type VALID_PTR_AXIOMS
  (Import P : PTRS_INTF)
  (Import INTF : VALUES_INTF_FUNCTOR P)
  (Import CC : CPP_LOGIC_CLASS)
  (Import CPP : CPP_LOGIC P INTF CC).

  Implicit Types (p : ptr).

  Section with_cpp.
    Context `{cpp_logic} {σ : genv}.

    Axiom invalid_ptr_invalid : forall vt,
      _valid_ptr vt invalid_ptr |-- False.

    (** Justified by [https://eel.is/c++draft/expr.add#4.1]. *)
    Axiom _valid_ptr_nullptr_sub_false : forall vt ty (i : Z) (_ : i <> 0),
      _valid_ptr vt (nullptr ,, o_sub σ ty i) |-- False.
    (*
    TODO Controversial; if [f] is the first field, [nullptr->f] or casts relying on
    https://eel.is/c++draft/basic.compound#4 might invalidate this.
    To make this valid, we could ensure our axiomatic semantics produces
    [nullptr] instead of [nullptr ., o_field]. *)
    (* Axiom _valid_ptr_nullptr_field_false : forall vt f,
      _valid_ptr vt (nullptr ,, o_field σ f) |-- False. *)

    (** These axioms are named after the predicate in the conclusion. *)

    (**
    TODO: The intended proof of [strict_valid_ptr_sub] assumes that, if [p']
    normalizes to [p ., [ ty ! i ]], then [valid_ptr p'] is defined to imply
    validity of all pointers from [p] to [p'].

    Note that `arrR` exposes stronger reasoning principles, but this might still be useful.
    *)
    Axiom strict_valid_ptr_sub : ∀ (i j k : Z) p ty vt1 vt2,
      (i <= j < k)%Z ->
      _valid_ptr vt1 (p ,, o_sub σ ty i) |--
      _valid_ptr vt2 (p ,, o_sub σ ty k) -* strict_valid_ptr (p ,, o_sub σ ty j).

    (** XXX: this axiom is convoluted but
    TODO: The intended proof of [strict_valid_ptr_field_sub] (and friends) is that
    (1) if [p'] normalizes to [p'' ., [ ty ! i ]], then [valid_ptr p'] implies
    [valid_ptr p''].
    (2) [p ,, o_field σ f ,, o_sub σ ty i] will normalize to [p ,, o_field
    σ f ,, o_sub σ ty i], without cancellation.
    *)
    Axiom strict_valid_ptr_field_sub : ∀ (p : ptr) ty (i : Z) f vt,
      (0 < i)%Z ->
      _valid_ptr vt (p ,, o_field σ f ,, o_sub σ ty i) |-- strict_valid_ptr (p ,, o_field σ f).

    (* TODO: can we deduce that [p] is strictly valid? *)
    Axiom _valid_ptr_field : ∀ p f vt,
      _valid_ptr vt (p ,, o_field σ f) |-- _valid_ptr vt p.
    (* TODO: Pointers to fields can't be past-the-end, right?
    Except 0-size arrays. *)
    (* Axiom strict_valid_ptr_field : ∀ p f,
      valid_ptr (p ,, o_field σ f) |--
      strict_valid_ptr (p ,, o_field σ f). *)
    (* TODO: if we add [strict_valid_ptr_field], we can derive
    [_valid_ptr_field] from just [strict_valid_ptr_field] *)
    (* Axiom strict_valid_ptr_field : ∀ p f,
      strict_valid_ptr (p ,, o_field σ f) |-- strict_valid_ptr p. *)

    (* We're ignoring virtual inheritance here, since we have no plans to
    support it for now, but this might hold there too. *)

    (* We're ignoring virtual inheritance here, since we have no plans to
    support it for now, but this might hold there too. *)
    Axiom o_base_directly_derives : forall p base derived,
      strict_valid_ptr (p ,, o_base σ derived base) |--
      [| directly_derives σ derived base |].

    Axiom o_derived_directly_derives : forall p base derived,
      strict_valid_ptr (p ,, o_derived σ base derived) |--
      [| directly_derives σ derived base |].

    (* TODO: maybe add a validity of offsets to allow stating this more generally. *)
    Axiom valid_o_sub_size : forall p ty i vt,
      _valid_ptr vt (p ,, o_sub σ ty i) |-- [| is_Some (size_of σ ty) |].

    Axiom type_ptr_o_base : forall derived base p,
      class_derives derived [base] ->
      type_ptr (Tnamed derived) p ⊢ type_ptr (Tnamed base) (p ,, _base derived base).

    Axiom type_ptr_o_field_type_ptr : forall p fld cls (st : Struct),
      glob_def σ cls = Some (Gstruct st) ->
      fld ∈ s_fields st →
      type_ptr (Tnamed cls) p ⊢ type_ptr fld.(mem_type) (p .,
        {| f_name := fld.(mem_name) ; f_type := cls |}).

    Axiom type_ptr_o_sub : forall p (m n : N) ty,
      (m < n)%N ->
      type_ptr (Tarray ty n) p ⊢ type_ptr ty (p ,, _sub ty m).
  End with_cpp.
End VALID_PTR_AXIOMS.

Declare Module L : CPP_LOGIC PTRS_INTF_AXIOM VALUES_INTF_AXIOM LC.
Export L.

Declare Module Export VALID_PTR : VALID_PTR_AXIOMS PTRS_INTF_AXIOM VALUES_INTF_AXIOM LC L.

Section valid_ptr_code.
  Context `{Σ : cpp_logic} {σ : genv} (tu : translation_unit).

  Lemma code_at_valid   : forall f p,   code_at _ tu f p |-- valid_ptr p.
  Proof. intros. rewrite code_at_strict_valid; apply strict_valid_valid. Qed.
  Lemma method_at_valid : forall f p, method_at _ tu f p |-- valid_ptr p.
  Proof. intros. rewrite method_at_strict_valid; apply strict_valid_valid. Qed.
  Lemma ctor_at_valid   : forall f p,   ctor_at _ tu f p |-- valid_ptr p.
  Proof. intros. rewrite ctor_at_strict_valid; apply strict_valid_valid. Qed.
  Lemma dtor_at_valid   : forall f p,   dtor_at _ tu f p |-- valid_ptr p.
  Proof. intros. rewrite dtor_at_strict_valid; apply strict_valid_valid. Qed.
End valid_ptr_code.

Section pinned_ptr_def.
  Context `{Σ : cpp_logic}.

  Definition exposed_ptr_def p : mpred :=
    valid_ptr p ** ∃ aid, [| ptr_alloc_id p = Some aid |] ** exposed_aid aid.
  Definition exposed_ptr_aux : seal exposed_ptr_def. Proof. by eexists. Qed.
  Definition exposed_ptr := exposed_ptr_aux.(unseal).
  Definition exposed_ptr_eq : exposed_ptr = _ := exposed_ptr_aux.(seal_eq).

  #[global] Hint Opaque exposed_ptr : typeclass_instances.

  #[global] Instance exposed_ptr_persistent p : Persistent (exposed_ptr p).
  Proof. rewrite exposed_ptr_eq. apply _. Qed.
  #[global] Instance exposed_ptr_affine p : Affine (exposed_ptr p).
  Proof. rewrite exposed_ptr_eq. apply _. Qed.
  #[global] Instance exposed_ptr_timeless p : Timeless (exposed_ptr p).
  Proof. rewrite exposed_ptr_eq. apply _. Qed.
  #[global] Instance exposed_ptr_valid p :
    Observe (valid_ptr p) (exposed_ptr p).
  Proof. rewrite exposed_ptr_eq. apply _. Qed.

  Lemma exposed_ptr_nullptr : |-- exposed_ptr nullptr.
  Proof.
    rewrite exposed_ptr_eq /exposed_ptr_def ptr_alloc_id_nullptr.
    iDestruct valid_ptr_nullptr as "$". iExists _.
    by iDestruct exposed_aid_null_alloc_id as "$".
  Qed.

  Lemma offset_exposed_ptr p o :
    valid_ptr (p ,, o) |-- exposed_ptr p -* exposed_ptr (p ,, o).
  Proof.
    rewrite exposed_ptr_eq /exposed_ptr_def.
    iIntros "#V' #[V E]". iDestruct (valid_ptr_alloc_id with "V'") as %?.
    iFrame "V'". by rewrite ptr_alloc_id_offset.
  Qed.

  Lemma offset2_exposed_ptr p o1 o2 :
    valid_ptr (p ,, o2) |-- exposed_ptr (p ,, o1) -* exposed_ptr (p ,, o2).
  Proof.
    rewrite exposed_ptr_eq /exposed_ptr_def.
    iIntros "#V2 #[V1 E]"; iFrame "V2".
    iDestruct (valid_ptr_alloc_id with "V1") as %?.
    iDestruct (valid_ptr_alloc_id with "V2") as %?.
    by rewrite ptr_alloc_id_offset // ptr_alloc_id_offset.
  Qed.

  Lemma offset_inv_exposed_ptr p o :
    valid_ptr p |-- exposed_ptr (p ,, o) -* exposed_ptr p.
  Proof. rewrite -{1 3}(offset_ptr_id p). apply offset2_exposed_ptr. Qed.

  (** Physical representation of pointers. *)
  (** [pinned_ptr va p] states that the abstract pointer [p] is tied to a
    virtual address [va].
    [pinned_ptr] will only hold on pointers that are associated to addresses,
    but other pointers exist. *)
  Definition pinned_ptr_def (va : vaddr) (p : ptr) : mpred :=
    [| ptr_vaddr p = Some va |] ** exposed_ptr p.
  Definition pinned_ptr_aux : seal pinned_ptr_def. Proof. by eexists. Qed.
  Definition pinned_ptr := pinned_ptr_aux.(unseal).
  Definition pinned_ptr_eq : pinned_ptr = _ := pinned_ptr_aux.(seal_eq).

  #[global] Hint Opaque pinned_ptr : typeclass_instances.

  #[global] Instance pinned_ptr_persistent va p : Persistent (pinned_ptr va p).
  Proof. rewrite pinned_ptr_eq. apply _. Qed.
  #[global] Instance pinned_ptr_affine va p : Affine (pinned_ptr va p).
  Proof. rewrite pinned_ptr_eq. apply _. Qed.
  #[global] Instance pinned_ptr_timeless va p : Timeless (pinned_ptr va p).
  Proof. rewrite pinned_ptr_eq. apply _. Qed.

  Lemma pinned_ptr_intro p va :
    ptr_vaddr p = Some va -> exposed_ptr p |-- pinned_ptr va p.
  Proof. rewrite pinned_ptr_eq /pinned_ptr_def. by iIntros (?) "$". Qed.

  #[global] Instance pinned_ptr_ptr_vaddr va p :
    Observe [| ptr_vaddr p = Some va |] (pinned_ptr va p).
  Proof. rewrite pinned_ptr_eq. apply _. Qed.

  Lemma pinned_ptr_change_va_eq (p : ptr) (va va' : vaddr)
    (Heq : ptr_vaddr p = Some va) :
    pinned_ptr va' p |--  [| va' = va |] ** pinned_ptr va p.
  Proof.
    iIntros "#P".
    iDestruct (observe_elim_pure (ptr_vaddr p = Some va') with "P") as %?.
    simplify_eq. auto.
  Qed.

  Lemma pinned_ptr_change_va p va va'
    (Heq : ptr_vaddr p = Some va) :
    pinned_ptr va' p |-- pinned_ptr va p.
  Proof. rewrite pinned_ptr_change_va_eq //. by iIntros "[_ $]". Qed.

  #[global] Instance pinned_ptr_agree va1 va2 p :
    Observe2 [| va1 = va2 |] (pinned_ptr va1 p) (pinned_ptr va2 p).
  Proof.
    iIntros "#P1 #P2 !>".
    iDestruct (observe_elim_pure (_ = _) with "P1") as %?.
    iDestruct (observe_elim_pure (_ = _) with "P2") as %?; simplify_eq.
    by [].
  Qed.

  #[global] Instance pinned_ptr_valid va p :
    Observe (valid_ptr p) (pinned_ptr va p).
  Proof. rewrite pinned_ptr_eq. apply _. Qed.

  (** Just a corollary of [provides_storage_same_address] in the style of
  [provides_storage_pinned_ptr]. *)
  Lemma provides_storage_pinned_ptr_pure {storage_ptr obj_ptr aty va} :
    ptr_vaddr storage_ptr = Some va ->
    provides_storage storage_ptr obj_ptr aty |-- [| ptr_vaddr obj_ptr = Some va |].
  Proof. rewrite provides_storage_same_address. by iIntros (HP <-). Qed.
End pinned_ptr_def.

#[deprecated(note="Use pinned_ptr_ptr_vaddr", since="2022-01-18")]
Notation pinned_ptr_pinned_ptr_pure := pinned_ptr_ptr_vaddr (only parsing).

Section with_cpp.
  Context `{Σ : cpp_logic} {σ : genv}.

  Lemma same_address_bool_null p tv :
    _valid_ptr tv p |--
    [| same_address_bool p nullptr = bool_decide (p = nullptr) |].
  Proof. rewrite same_address_eq_null; iIntros "!%". apply bool_decide_ext. Qed.

  Lemma valid_ptr_zero_null p :
    ptr_vaddr p = Some 0%N ->
    valid_ptr p |-- [| p = nullptr |].
  Proof.
    rewrite same_address_eq_null.
    iIntros (Haddr [Hsuff _]) "!%". apply: Hsuff.
    rewrite same_address_iff ptr_vaddr_nullptr; naive_solver.
  Qed.

  Lemma valid_ptr_nonnull_nonzero p :
    p <> nullptr ->
    valid_ptr p |-- [| ptr_vaddr p <> Some 0%N |].
  Proof.
    destruct (decide (ptr_vaddr p = Some 0%N)); last naive_solver.
    rewrite valid_ptr_zero_null; naive_solver.
  Qed.

  Lemma type_ptr_nonnull ty p :
    type_ptr ty p |-- [| p <> nullptr |].
  Proof. rewrite -{1}(offset_ptr_id p). apply type_ptr_off_nonnull. Qed.

  #[global] Instance type_ptr_observe_nonnull ty p :
    Observe [| p <> nullptr |] (type_ptr ty p).
  Proof. rewrite type_ptr_nonnull. refine _. Qed.

  #[global] Instance provides_storage_preserves_nullptr {storage_ptr obj_ptr aty} :
    Observe [| storage_ptr = nullptr <-> obj_ptr = nullptr |] (provides_storage storage_ptr obj_ptr aty).
  Proof.
    apply observe_intro_only_provable; iIntros "PS".
    iDestruct (provides_storage_same_address with "PS") as %Hsm.
    iDestruct (provides_storage_valid_obj_ptr with "PS") as "#VO".
    iDestruct (provides_storage_valid_storage_ptr with "PS") as "#VS {PS}".
    iDestruct (same_address_eq_null with "VO") as %[HeqO _].
    iDestruct (same_address_eq_null with "VS") as %[HeqS _].
    iIntros "!%"; split; intros ->.
    - apply HeqO, symmetry, Hsm.
    - apply HeqS, Hsm.
  Qed.

  #[global] Instance provides_storage_preserves_nonnull {storage_ptr obj_ptr aty} :
    Observe [| storage_ptr <> nullptr <-> obj_ptr <> nullptr |] (provides_storage storage_ptr obj_ptr aty).
  Proof.
    apply observe_intro_only_provable. iIntros "PS".
    by iDestruct (provides_storage_preserves_nullptr with "PS") as "#-> {PS}".
  Qed.

  #[global] Instance pinned_ptr_unique va va' p :
    Observe2 [| va = va' |] (pinned_ptr va p) (pinned_ptr va' p).
  Proof.
    rewrite pinned_ptr_eq.
    iIntros "[%H1 _] [%H2 _] !> !%". congruence.
  Qed.

  Lemma offset_2_pinned_ptr_pure o1 o2 z1 z2 va p :
    eval_offset σ o1 = Some z1 ->
    eval_offset σ o2 = Some z2 ->
    ptr_vaddr (p ,, o1) = Some va ->
    valid_ptr p |-- valid_ptr (p ,, o1) -* valid_ptr (p ,, o2) -*
    [| ptr_vaddr (p ,, o2) = Some (Z.to_N (Z.of_N va - z1 + z2)) |].
  Proof.
    iIntros (He1 He2 Hpin1) "V V1 V2".
    iDestruct (offset_inv_pinned_ptr_pure with "V1") as %[??]; [done..|].
    iDestruct (offset_pinned_ptr_pure with "V2") as %Hgoal; [done..|].
    iIntros "!%". by rewrite Z2N.id in Hgoal.
  Qed.

  Lemma pinned_ptr_null : |-- pinned_ptr 0 nullptr.
  Proof.
    rewrite pinned_ptr_eq /pinned_ptr_def.
    iFrame (ptr_vaddr_nullptr).
    iApply exposed_ptr_nullptr.
  Qed.

  #[global] Instance pinned_ptr_zero_is_null (p : ptr) :
    Observe [| p = nullptr |] (pinned_ptr 0 p).
  Proof.
    rewrite pinned_ptr_eq /pinned_ptr_def.
    iIntros "[%Heq #E]".
    rewrite -valid_ptr_zero_null //.
    by iApply (exposed_ptr_valid with "E").
  Qed.

  #[global] Instance pinned_ptr_null_is_zero addr :
    Observe [| addr = 0 |]%N (pinned_ptr addr nullptr).
  Proof.
    rewrite pinned_ptr_eq /pinned_ptr_def ptr_vaddr_nullptr.
    apply: (observe_derive_only_provable (Some 0%N = Some addr)); naive_solver.
  Qed.

  Lemma pinned_ptr_same_address pp1 pp2 v :
    same_address pp1 pp2 ->
    exposed_ptr pp2 |-- pinned_ptr v pp1 -* pinned_ptr v pp2.
  Proof.
    rewrite pinned_ptr_eq/pinned_ptr_def.
    by iIntros ((? & -> & ->)%same_address_iff) "$ [%Hp _] !%".
  Qed.

  Lemma offset_pinned_ptr o z va p :
    eval_offset _ o = Some z ->
    valid_ptr (p ,, o) |--
    pinned_ptr va p -* pinned_ptr (Z.to_N (Z.of_N va + z)) (p ,, o).
  Proof.
    rewrite pinned_ptr_eq /pinned_ptr_def.
    iIntros (He) "#V' #(%P & E)".
    iDestruct (offset_pinned_ptr_pure with "V'") as "$"; [done..|].
    by iApply offset_exposed_ptr.
  Qed.

  Lemma offset_inv_pinned_ptr o z va p :
    eval_offset _ o = Some z ->
    valid_ptr p |-- pinned_ptr va (p ,, o) -*
    [| 0 <= Z.of_N va - z |]%Z ** pinned_ptr (Z.to_N (Z.of_N va - z)) p.
  Proof.
    rewrite pinned_ptr_eq /pinned_ptr_def.
    iIntros (He) "#V #(%P & E)".
    iDestruct (offset_inv_pinned_ptr_pure with "[]") as "-#[$$]"; [done..| |].
    { by iApply (observe with "E"). }
    by iApply offset_inv_exposed_ptr.
  Qed.

  Lemma offset2_pinned_ptr o1 o2 z1 z2 va p :
    eval_offset σ o1 = Some z1 ->
    eval_offset σ o2 = Some z2 ->
    valid_ptr p |-- valid_ptr (p ,, o1) -* valid_ptr (p ,, o2) -*
    pinned_ptr va (p ,, o1) -*
    pinned_ptr (Z.to_N (Z.of_N va - z1 + z2)) (p ,, o2).
  Proof.
    rewrite pinned_ptr_eq /pinned_ptr_def.
    iIntros (He1 He2) "V V1 #V2 #(%P & E)".
    iDestruct (offset_2_pinned_ptr_pure with "V V1 V2") as "$"; [done..|].
    by iApply offset2_exposed_ptr.
  Qed.

  Lemma pinned_ptr_aligned_divide va n p :
    pinned_ptr va p ⊢
    [| aligned_ptr n p <-> (n | va)%N |].
  Proof.
    rewrite pinned_ptr_eq /pinned_ptr_def; iIntros "(%P & _) !%".
    exact: pinned_ptr_pure_aligned_divide.
  Qed.

  Lemma pinned_ptr_pure_type_divide_1 va n p ty
    (Hal : align_of ty = Some n) :
    type_ptr ty p ⊢ [| ptr_vaddr p = Some va |] -∗ [| (n | va)%N |].
  Proof.
    rewrite type_ptr_aligned_pure. iIntros "!%".
    exact: pinned_ptr_pure_divide_1.
  Qed.

  Lemma pinned_ptr_type_divide_1 va n p ty
    (Hal : align_of ty = Some n) :
    type_ptr ty p ⊢ pinned_ptr va p -∗ [| (n | va)%N |].
  Proof.
    rewrite pinned_ptr_eq /pinned_ptr_def.
    iIntros "#? #(? & _)". by iApply pinned_ptr_pure_type_divide_1.
  Qed.

  Lemma shift_pinned_ptr_sub ty z va (p1 p2 : ptr) o:
    size_of σ ty = Some o ->
    p1 ,, o_sub _ ty z = p2 ->
        valid_ptr p2 ** pinned_ptr va p1
    |-- pinned_ptr (Z.to_N (Z.of_N va + z * Z.of_N o)) p2.
  Proof.
    move => o_eq <-.
    iIntros "[val pin1]".
    iApply (offset_pinned_ptr _ with "val") => //.
    rewrite eval_o_sub o_eq /= Z.mul_comm //.
  Qed.

  Lemma _valid_valid p vt : _valid_ptr vt p |-- valid_ptr p.
  Proof. case: vt => [|//]. exact: strict_valid_valid. Qed.

  Lemma valid_ptr_sub (i j k : Z) p ty vt
    (Hj : (i <= j <= k)%Z) :
    _valid_ptr vt (p ,, o_sub σ ty i) |--
    _valid_ptr vt (p ,, o_sub σ ty k) -* valid_ptr (p ,, o_sub σ ty j).
  Proof.
    destruct (decide (j = k)) as [->|Hne].
    { rewrite -_valid_valid. by iIntros "_ $". }
    rewrite -strict_valid_valid. apply strict_valid_ptr_sub. lia.
  Qed.

  Lemma _valid_ptr_field_sub (i : Z) (p : ptr) ty f vt (Hle : (0 <= i)%Z) :
    _valid_ptr vt (p ,, o_field σ f ,, o_sub σ ty i) |-- _valid_ptr vt (p ,, o_field σ f).
  Proof.
    iIntros "V". case: (decide (i = 0)%Z) Hle => [-> _|Hne Hle].
    - iDestruct (valid_o_sub_size with "V") as %?.
      by rewrite offset_ptr_sub_0.
    - rewrite strict_valid_ptr_field_sub; last by lia.
      case: vt => //. by rewrite strict_valid_valid.
  Qed.

  Lemma o_base_derived_strict p base derived :
    strict_valid_ptr (p ,, o_base σ derived base) |--
    [| p ,, o_base σ derived base ,, o_derived σ base derived = p |].
  Proof.
    rewrite o_base_directly_derives. f_equiv => ?. exact: o_base_derived.
  Qed.

  Lemma o_derived_base_strict p base derived :
    strict_valid_ptr (p ,, o_derived σ base derived) |--
    [| p ,, o_derived σ base derived ,, o_base σ derived base = p |].
  Proof.
    rewrite o_derived_directly_derives. f_equiv => ?. exact: o_derived_base.
  Qed.

  Lemma o_derived_base_type p base derived ty :
    type_ptr ty (p ,, o_derived σ base derived) |--
    [| p ,, o_derived σ base derived ,, o_base σ derived base = p |].
  Proof. rewrite type_ptr_strict_valid. apply (o_derived_base_strict p). Qed.

  (** [_inv] because unlike [type_ptr_o_base] and [type_ptr_o_field_type_ptr],
  this lemma fits the [type_ptr _ (p ,, o) ⊢ type_ptr _ p] schema instead of the
  converse. *)
  Lemma type_ptr_o_derived_inv derived base p :
    class_derives derived [base] ->
    type_ptr (Tnamed derived) (p ,, _derived base derived) |--
    type_ptr (Tnamed base) p.
  Proof.
    iIntros (Hcd) "T".
    iDestruct (o_derived_base_type with "T") as %Hp.
    by rewrite (type_ptr_o_base _ _ _ Hcd) Hp.
  Qed.

  (** [p] is a valid pointer value in the sense of the standard, or
  "standard-valid" (https://eel.is/c++draft/basic.compound#3.1), that is both
  valid (in our sense) and live.

  In particular, [p] is a valid pointer value even when accounting for
  pointer zapping.
  *)
  Definition _valid_live_ptr vt (p : ptr) : mpred :=
    _valid_ptr vt p ∗ live_ptr p.
  Definition valid_live_ptr p : mpred := _valid_live_ptr Relaxed p.
  Definition strict_valid_live_ptr p : mpred := _valid_live_ptr Strict p.

  #[global] Instance tptsto_flip_mono :
    Proper (flip genv_leq ==> eq ==> eq ==> eq ==> eq ==> flip (⊢))
      (@tptsto _ Σ).
  Proof. repeat intro. exact: tptsto_mono. Qed.

  #[global] Instance tptsto_as_cfractional ty : AsCFractional2 (tptsto ty).
  Proof. solve_as_cfrac. Qed.

  #[global] Instance identity_as_cfractional this mdc :
    AsCFractional1 (identity this mdc).
  Proof. solve_as_cfrac. Qed.

  #[global] Instance tptsto_observe_nonnull t q p v :
    Observe [| p <> nullptr |] (tptsto t q p v).
  Proof.
    apply: observe_intro.
    destruct (ptr_eq_dec p nullptr); subst; last by eauto.
    rewrite {1}tptsto_nonnull. exact: bi.False_elim.
  Qed.

  Lemma tptsto_disjoint ty c1 c2 q p v1 v2 :
    tptsto ty (cQp.mk c1 1) p v1 ** tptsto ty (cQp.mk c2 q) p v2 |-- False.
  Proof.
    iIntros "[T1 T2]".
    iDestruct (tptsto_agree with "T1 T2") as %Hvs.
    iDestruct (tptsto_val_related_transport $! Hvs with "T1") as "T1".
    iCombine "T1 T2" as "T".
    by iDestruct (cfrac_valid_2 with "T") as %?%Qp.not_add_le_l.
  Qed.

  (** *** Just wrappers. *)
  (** We can lift validity entailments through [Observe] (using
  [Observe_mono]. These are not instances, to avoid causing slowdowns in
  proof search. *)
  Lemma observe_strict_valid_valid
    `(Hobs : !Observe (strict_valid_ptr p) P) : Observe (valid_ptr p) P.
  Proof. by rewrite -strict_valid_valid. Qed.

  Lemma observe_type_ptr_strict_valid
    `(Hobs : !Observe (type_ptr ty p) P) : Observe (strict_valid_ptr p) P.
  Proof. by rewrite -type_ptr_strict_valid. Qed.

  Lemma observe_type_ptr_valid_plus_one
    `(Hobs : !Observe (type_ptr ty p) P) : Observe (valid_ptr (p ,, o_sub σ ty 1)) P.
  Proof. by rewrite -type_ptr_valid_plus_one. Qed.

  Lemma type_ptr_valid ty p : type_ptr ty p |-- valid_ptr p.
  Proof. by rewrite type_ptr_strict_valid strict_valid_valid. Qed.

  #[global] Instance type_ptr_size_observe ty p :
    Observe [| is_Some (size_of σ ty) |] (type_ptr ty p).
  Proof. rewrite type_ptr_size. apply _. Qed.

  #[global] Instance valid_ptr_sub_0 (p : ptr) (ty : type) :
    HasSize ty ->
    Observe (valid_ptr (p ,, o_sub σ ty 0)) (valid_ptr p).
  Proof. intros. rewrite o_sub_0 // offset_ptr_id. refine _. Qed.
  #[global] Instance type_ptr_sub_0 (p : ptr) (ty : type) :
    HasSize ty ->
    Observe (valid_ptr (p ,, o_sub σ ty 0)) (type_ptr ty p).
  Proof.
    intros. by rewrite type_ptr_valid; apply valid_ptr_sub_0.
  Qed.
  #[global] Instance type_ptr_valid_ptr_next (p : ptr) (ty : type) (m n : Z) :
    (m = n + 1)%Z ->
    Observe (valid_ptr (p ,, o_sub σ ty m)) (type_ptr ty (p ,, o_sub σ ty n)).
  Proof.
    intros; subst.
    iIntros "X".
    iDestruct (observe (valid_ptr (p ,, o_sub _ _ _ ,, o_sub _ _ _)) with "X") as "z".
    apply observe_type_ptr_valid_plus_one. refine _.
    by rewrite o_sub_sub.
  Qed.

  Lemma same_alloc_refl p : valid_ptr p ⊢ [| same_alloc p p |].
  Proof.
    rewrite valid_ptr_alloc_id same_alloc_iff. iIntros "!%". case; naive_solver.
  Qed.

  Lemma live_has_alloc_id p :
    live_ptr p ⊢ ∃ aid, [| ptr_alloc_id p = Some aid |] ∗ live_alloc_id aid.
  Proof. rewrite /live_ptr; iIntros. case: (ptr_alloc_id p) => /= [aid|]; eauto. Qed.
End with_cpp.


(* -------------------------------------------------------------------------- *
 *                     Vellvm - the Verified LLVM project                     *
 *                                                                            *
 *     Copyright (c) 2018 Steve Zdancewic <stevez@cis.upenn.edu>              *
 *                                                                            *
 *   This file is distributed under the terms of the GNU General Public       *
 *   License as published by the Free Software Foundation, either version     *
 *   3 of the License, or (at your option) any later version.                 *
 ---------------------------------------------------------------------------- *)

From Coq Require Import
     ZArith List String Omega
     FSets.FMapAVL
     Structures.OrderedTypeEx
     ZMicromega.

From ITree Require Import
     ITree
     Basics.Basics
     Events.Exception
     Events.State.

Import Basics.Basics.Monads.

From ExtLib Require Import
     Structures.Monads
     Programming.Eqv
     Programming.Show
     Data.String.

From Vellvm Require Import
     LLVMAst
     Util
     DynamicTypes
     Denotation
     MemoryAddress
     LLVMEvents
     Error
     Coqlib
     Numeric.Integers
     Numeric.Floats.

Import MonadNotation.
Import EqvNotation.
Import ListNotations.

Set Implicit Arguments.
Set Contextual Implicit.

Module A : MemoryAddress.ADDRESS with Definition addr := (Z * Z) % type.
  Definition addr := (Z * Z) % type.
  Definition null := (0, 0).
  Definition t := addr.
  Lemma eq_dec : forall (a b : addr), {a = b} + {a <> b}.
  Proof.
    intros [a1 a2] [b1 b2].
    destruct (a1 ~=? b1);
      destruct (a2 ~=? b2); unfold eqv in *; unfold AstLib.eqv_int in *; subst.
    - left; reflexivity.
    - right. intros H. inversion H; subst. apply n. reflexivity.
    - right. intros H. inversion H; subst. apply n. reflexivity.
    - right. intros H. inversion H; subst. apply n. reflexivity.
  Qed.
End A.

Module Make(LLVMEvents: LLVM_INTERACTIONS(A)).
  Import LLVMEvents.
  Import DV.

  Definition addr := A.addr.

  Module IM := FMapAVL.Make(Coq.Structures.OrderedTypeEx.Z_as_OT).
  Definition IntMap := IM.t.

  Definition add {a} k (v:a) := IM.add k v.
  Definition delete {a} k (m:IntMap a) := IM.remove k m.
  Definition member {a} k (m:IntMap a) := IM.mem k m.
  Definition lookup {a} k (m:IntMap a) := IM.find k m.
  Definition empty {a} := @IM.empty a.

  Fixpoint add_all {a} ks (m:IntMap a) :=
    match ks with
    | [] => m
    | (k,v) :: tl => add k v (add_all tl m)
    end.

  Fixpoint add_all_index {a} vs (i:Z) (m:IntMap a) :=
    match vs with
    | [] => m
    | v :: tl => add i v (add_all_index tl (i+1) m)
    end.

  (* Give back a list of values from i to (i + sz) - 1 in m. *)
  (* Uses def as the default value if a lookup failed. *)
  Definition lookup_all_index {a} (i:Z) (sz:Z) (m:IntMap a) (def:a) : list a :=
    List.map (fun x =>
                let x' := lookup (Z.of_nat x) m in
                match x' with
                | None => def
                | Some val => val
                end) (seq (Z.to_nat i) (Z.to_nat sz)).

  Definition union {a} (m1 : IntMap a) (m2 : IntMap a)
    := IM.map2 (fun mx my =>
                  match mx with | Some x => Some x | None => my end) m1 m2.

  Definition maximumBy {A} (leq : A -> A -> bool) (def : A) (l : list A) : A :=
    fold_left (fun a b => if leq a b then b else a) l def.

  (* Get a fresh key for use in memory map *)
  Definition next_key {a} (m : IM.t a) : Z
    := let keys := map fst (IM.elements m) in
       1 + maximumBy Z.leb (-1) keys.

  Inductive SByte :=
  | Byte : byte -> SByte
  | Ptr : addr -> SByte
  | PtrFrag : SByte
  | SUndef : SByte.

  (* TODO SAZ: mem_block should keep track of its allocation size so
    that operations can fail if they are out of range

    CB: I think this might happen implicitly with make_empty_block --
    it initializes the IntMap with only the valid indices. As long as the
    lookup functions handle this properly, anyway.
   *)

  (* Simple view of memory *)
  Definition mem_block := IntMap SByte.
  Definition memory    := IntMap mem_block.

  (* Allocation stacks *)
  Definition mem_frame := list Z.  (* A list of block ids that need to be freed when popped *)
  Definition mem_stack := list mem_frame.

  (* Memory + stack for freeing *)
  Definition memory_stack : Type := memory * mem_stack.

  (* Definition undef := DVALUE_Undef. (* TODO: should this be an empty block? *) *)

  Fixpoint max_default (l:list Z) (x:Z) :=
    match l with
    | [] => x
    | h :: tl =>
      max_default tl (if h >? x then h else x)
    end.

  Definition oracle (m:memory) : Z :=
    let keys := List.map fst (IM.elements m) in
    let max := max_default keys 0 in
    let offset := 1 in (* TODO: This should be "random" *)
    max + offset.

  (* Computes the byte size of this type. *)
  Fixpoint sizeof_dtyp (ty:dtyp) : Z :=
    match ty with
    | DTYPE_I sz => 8 (* All integers are padded to 8 bytes. *)
    | DTYPE_Pointer => 8
    | DTYPE_Struct l => fold_left (fun x acc => x + sizeof_dtyp acc) l 0
    | DTYPE_Array sz ty' => sz * sizeof_dtyp ty'
    | DTYPE_Float => 4
    | DTYPE_Double => 8
    | _ => 0 (* TODO: add support for more types as necessary *)
    end.

  (* Convert integer to its byte representation. *)
  Fixpoint bytes_of_int (n: nat) (x: Z) {struct n}: list byte :=
    match n with
    | O => nil
    | S m => Byte.repr x :: bytes_of_int m (x / 256)
    end.

  Fixpoint int_of_bytes (l: list byte): Z :=
    match l with
    | nil => 0
    | b :: l' => Byte.unsigned b + int_of_bytes l' * 256
    end.

  (* CB TODO: Is interpreting everything except for bytes as undef reasonable? *)
  Definition Sbyte_to_byte (sb:SByte) : option byte :=
    match sb with
    | Byte b => ret b
    | Ptr _ | PtrFrag | SUndef => None
    end.

  Definition Z_to_sbyte_list (count:nat) (z:Z) : list SByte :=
    List.map Byte (bytes_of_int count z).

  Definition Sbyte_to_byte_list (sb:SByte) : list byte :=
    match sb with
    | Byte b => [b]
    | Ptr _ | PtrFrag | SUndef => []
    end.

  Definition sbyte_list_to_byte_list (bytes:list SByte) : list byte :=
    List.flat_map Sbyte_to_byte_list bytes.

  Definition sbyte_list_to_Z (bytes:list SByte) : Z :=
    int_of_bytes (sbyte_list_to_byte_list bytes).

  (** Length properties *)

  Lemma length_bytes_of_int:
    forall n x, List.length (bytes_of_int n x) = n.
  Proof.
    induction n; simpl; intros. auto. decEq. auto.
  Qed.

  Lemma int_of_bytes_of_int:
    forall n x,
      int_of_bytes (bytes_of_int n x) = x mod (two_p (Z.of_nat n * 8)).
  Proof.
    induction n; intros.
    simpl. rewrite Zmod_1_r. auto.
    Opaque Byte.wordsize.
    rewrite Nat2Z.inj_succ. simpl.
    replace (Z.succ (Z.of_nat n) * 8) with (Z.of_nat n * 8 + 8) by omega.
    rewrite two_p_is_exp; try omega.
    rewrite Zmod_recombine. rewrite IHn. rewrite Z.add_comm.
    change (Byte.unsigned (Byte.repr x)) with (Byte.Z_mod_modulus x).
    rewrite Byte.Z_mod_modulus_eq. reflexivity.
    apply two_p_gt_ZERO. omega. apply two_p_gt_ZERO. omega.
  Qed.

  (* Serializes a dvalue into its SByte-sensitive form. *)
  Fixpoint serialize_dvalue (dval:dvalue) : list SByte :=
    match dval with
    | DVALUE_Addr addr => (Ptr addr) :: (repeat PtrFrag 7)
    | DVALUE_I1 i => Z_to_sbyte_list 8 (unsigned i)
    | DVALUE_I8 i => Z_to_sbyte_list 8 (unsigned i)
    | DVALUE_I32 i => Z_to_sbyte_list 8 (unsigned i)
    | DVALUE_I64 i => Z_to_sbyte_list 8 (unsigned i)
    | DVALUE_Float f => Z_to_sbyte_list 4 (unsigned (Float32.to_bits f))
    | DVALUE_Double d => Z_to_sbyte_list 8 (unsigned (Float.to_bits d))
    | DVALUE_Struct fields | DVALUE_Array fields =>
                             (* note the _right_ fold is necessary for byte ordering. *)
                             fold_right (fun 'dv acc => ((serialize_dvalue dv) ++ acc) % list) [] fields
    | _ => [] (* TODO add more dvalues as necessary *)
    end.

  (* CB TODO: does this really not exist somewhere? *)
  Definition is_some {A} (o : option A) :=
    match o with
    | Some x => true
    | None => false
    end.

  Definition all_not_sundef (bytes : list SByte) : bool :=
    forallb is_some (map Sbyte_to_byte bytes).

  (* Deserialize a list of SBytes into a uvalue, assuming that none of the bytes are undef *)
  Fixpoint deserialize_sbytes_defined (bytes:list SByte) (t:dtyp) : uvalue :=
    match t with
    | DTYPE_I sz =>
      let des_int := sbyte_list_to_Z bytes in
      match sz with
      | 1  => UVALUE_I1 (repr des_int)
      | 8  => UVALUE_I8 (repr des_int)
      | 32 => UVALUE_I32 (repr des_int)
      | 64 => UVALUE_I64 (repr des_int)
      | _  => UVALUE_None (* invalid size. *)
      end
    | DTYPE_Float => UVALUE_Float (Float32.of_bits (repr (sbyte_list_to_Z bytes)))
    | DTYPE_Double => UVALUE_Double (Float.of_bits (repr (sbyte_list_to_Z bytes)))

    | DTYPE_Pointer =>
      match bytes with
      | Ptr addr :: tl => UVALUE_Addr addr
      | _ => UVALUE_None (* invalid pointer. *)
      end
    | DTYPE_Array sz t' =>
      let fix array_parse count byte_sz bytes :=
          match count with
          | O => []
          | S n => (deserialize_sbytes_defined (firstn byte_sz bytes) t')
                     :: array_parse n byte_sz (skipn byte_sz bytes)
          end in
      UVALUE_Array (array_parse (Z.to_nat sz) (Z.to_nat (sizeof_dtyp t')) bytes)
    | DTYPE_Struct fields =>
      let fix struct_parse typ_list bytes :=
          match typ_list with
          | [] => []
          | t :: tl =>
            let size_ty := Z.to_nat (sizeof_dtyp t) in
            (deserialize_sbytes_defined (firstn size_ty bytes) t)
              :: struct_parse tl (skipn size_ty bytes)
          end in
      UVALUE_Struct (struct_parse fields bytes)
    | _ => UVALUE_None (* TODO add more as serialization support increases *)
    end.

  Definition deserialize_sbytes (bytes : list SByte) (t : dtyp) : uvalue :=
    if all_not_sundef bytes
    then deserialize_sbytes_defined bytes t
    else UVALUE_Undef t.

  (* Todo - complete proofs, and think about moving to MemoryProp module. *)
  (* The relation defining serializable dvalues. *)
  Inductive serialize_defined : dvalue -> Prop :=
  | d_addr: forall addr,
      serialize_defined (DVALUE_Addr addr)
  | d_i1: forall i1,
      serialize_defined (DVALUE_I1 i1)
  | d_i8: forall i1,
      serialize_defined (DVALUE_I8 i1)
  | d_i32: forall i32,
      serialize_defined (DVALUE_I32 i32)
  | d_i64: forall i64,
      serialize_defined (DVALUE_I64 i64)
  | d_struct_empty:
      serialize_defined (DVALUE_Struct [])
  | d_struct_nonempty: forall dval fields_list,
      serialize_defined dval ->
      serialize_defined (DVALUE_Struct fields_list) ->
      serialize_defined (DVALUE_Struct (dval :: fields_list))
  | d_array_empty:
      serialize_defined (DVALUE_Array [])
  | d_array_nonempty: forall dval fields_list,
      serialize_defined dval ->
      serialize_defined (DVALUE_Array fields_list) ->
      serialize_defined (DVALUE_Array (dval :: fields_list)).

  (* Lemma assumes all integers encoded with 8 bytes. *)

  Inductive sbyte_list_wf : list SByte -> Prop :=
  | wf_nil : sbyte_list_wf []
  | wf_cons : forall b l, sbyte_list_wf l -> sbyte_list_wf (Byte b :: l)
  .

  (*
Lemma sbyte_list_to_Z_inverse:
  forall i1 : int1, (sbyte_list_to_Z (Z_to_sbyte_list 8 (Int1.unsigned i1))) =
               (Int1.unsigned i1).
Proof.
  intros i1.
  destruct i1. simpl.
Admitted. *)

  (*
Lemma serialize_inverses : forall dval,
    serialize_defined dval -> exists typ, deserialize_sbytes (serialize_dvalue dval) typ = dval.
Proof.
  intros. destruct H.
  (* DVALUE_Addr. Type of pointer is not important. *)
  - exists (TYPE_Pointer TYPE_Void). reflexivity.
  (* DVALUE_I1. Todo: subversion lemma for integers. *)
  - exists (TYPE_I 1).
    simpl.

    admit.
  (* DVALUE_I32. Todo: subversion lemma for integers. *)
  - exists (TYPE_I 32). admit.
  (* DVALUE_I64. Todo: subversion lemma for integers. *)
  - exists (TYPE_I 64). admit.
  (* DVALUE_Struct [] *)
  - exists (TYPE_Struct []). reflexivity.
  (* DVALUE_Struct fields *)
  - admit.
  (* DVALUE_Array [] *)
  - exists (TYPE_Array 0 TYPE_Void). reflexivity.
  (* DVALUE_Array fields *)
  - admit.
Admitted.
   *)

  (* Construct block indexed from 0 to n. *)
  Fixpoint init_block_h (n:nat) (m:mem_block) : mem_block :=
    match n with
    | O => add 0 SUndef m
    | S n' => add (Z.of_nat n) SUndef (init_block_h n' m)
    end.

  (* Initializes a block of n 0-bytes. *)
  Definition init_block (n:Z) : mem_block :=
    match n with
    | 0 => empty
    | Z.pos n' => init_block_h (BinPosDef.Pos.to_nat (n' - 1)) empty
    | Z.neg _ => empty (* invalid argument *)
    end.

  (* Makes a block appropriately sized for the given type. *)
  Definition make_empty_block (ty:dtyp) : mem_block :=
    init_block (sizeof_dtyp ty).

  Fixpoint handle_gep_h (t:dtyp) (b:Z) (off:Z) (vs:list dvalue) (m:memory) : err (memory * dvalue):=
    match vs with
    | v :: vs' =>
      match v with
      | DVALUE_I32 i =>
        let k := unsigned i in
        let n := BinIntDef.Z.to_nat k in
        match t with
        | DTYPE_Vector _ ta | DTYPE_Array _ ta =>
                              handle_gep_h ta b (off + k * (sizeof_dtyp ta)) vs' m
        | DTYPE_Struct ts | DTYPE_Packed_struct ts => (* Handle these differently in future *)
                            let offset := fold_left (fun acc t => acc + sizeof_dtyp t)
                                                    (firstn n ts) 0 in
                            match nth_error ts n with
                            | None => failwith "overflow"
                            | Some t' =>
                              handle_gep_h t' b (off + offset) vs' m
                            end
        | _ => failwith ("non-i32-indexable type")
        end
      | DVALUE_I8 i =>
        let k := unsigned i in
        let n := BinIntDef.Z.to_nat k in
        match t with
        | DTYPE_Vector _ ta | DTYPE_Array _ ta =>
                              handle_gep_h ta b (off + k * (sizeof_dtyp ta)) vs' m
        | _ => failwith ("non-i8-indexable type")
        end
      | DVALUE_I64 i =>
        let k := unsigned i in
        let n := BinIntDef.Z.to_nat k in
        match t with
        | DTYPE_Vector _ ta | DTYPE_Array _ ta =>
                              handle_gep_h ta b (off + k * (sizeof_dtyp ta)) vs' m
        | _ => failwith ("non-i64-indexable type")
        end
      | _ => failwith "non-I32 index"
      end
    | [] => ret (m, DVALUE_Addr (b, off))
    end.

  Definition concretize_block (b:Z) (m:memory) : Z * memory :=
    match lookup b m with
    | None => (b, m)
    | Some block =>
      let i := oracle m in
      let fix loop es k block : mem_block :=
          match es with
          | [] => block
          | (i, e) :: tl => loop tl (k+1) (add (k + i) e block)
          end in
      (* TODO change source block SBYTES to associate abstract pointers with concrete memory. *)
      (i, add b (loop (IM.elements block) i block) m)
    end.

  Definition handle_gep (t:dtyp) (dv:dvalue) (vs:list dvalue) (m:memory) : err (memory * dvalue):=
    match vs with
    | DVALUE_I32 i :: vs' => (* TODO: Handle non i32 indices *)
      match dv with
      | DVALUE_Addr (b, o) =>
        handle_gep_h t b (o + (sizeof_dtyp t) * (unsigned i)) vs' m
      | _ => failwith "non-address"
      end
    | _ => failwith "non-I32 index"
    end.

  (* LLVM 5.0 memcpy
   According to the documentation: http://releases.llvm.org/5.0.0/docs/LangRef.html#llvm-memcpy-intrinsic
   this operation can never fail?  It doesn't return any status code...
   *)

  Definition handle_memcpy (args : List.list dvalue) (m:memory) : err memory :=
    match args with
    | DVALUE_Addr (dst_b, dst_o) ::
                  DVALUE_Addr (src_b, src_o) ::
                  DVALUE_I32 len ::
                  DVALUE_I32 align :: (* alignment ignored *)
                  DVALUE_I1 volatile :: [] (* volatile ignored *)  =>
      src_block <- trywith "memcpy src block not found" (lookup src_b m) ;;
                dst_block <- trywith "memcpy dst block not found" (lookup dst_b m) ;;
                let sdata := lookup_all_index src_o (unsigned len) src_block SUndef in
                let dst_block' := add_all_index sdata dst_o dst_block in
                let m' := add dst_b dst_block' m in
                (ret m' : err memory)

    | _ => failwith "memcpy got incorrect arguments"
    end.

  (* TODO:
   - we can use the handler combinators to make these more modular

   - these operations are too defined: load and store should fail if the
     address isn't in range
   *)

  Definition free_frame (f : mem_frame) (m : memory) : memory
    := fold_left (fun m key => delete key m) f m.

  Definition handle_memory {E} `{FailureE -< E} `{UBE -< E}: MemoryE ~> stateT memory_stack (itree E) :=
    fun _ e '(m, s) =>
      match e with
      | MemPush => ret ((m, [] :: s), tt)

      | MemPop =>
        match s with
        | [] => raise "Tried to pop memory stack, but there's nothing to pop."
        | frame :: stack_rest =>
          let m' := free_frame frame m in
          ret ((m', stack_rest), tt)
        end

      | Alloca t =>
        let new_block := make_empty_block t in
        let key := next_key m in
        let new_mem := add key new_block m in

        match s with
        | [] => raise "No stack frame for alloca."
        | frame :: stack_rest =>
          let new_stack := (key :: frame) :: stack_rest in
          ret ((new_mem, new_stack), DVALUE_Addr (key, 0))
        end

      | Load t dv =>
        match dv with
        | DVALUE_Addr (b, i) =>
          match lookup b m with
          | Some block =>
            ret ((m, s), deserialize_sbytes (lookup_all_index i (sizeof_dtyp t) block SUndef) t)
          (* Asking for a non-allocated block is undefined behaviour. *)
          | None => raiseUB "Loading from block that has never been allocated."
          end
        | _ => raise "Load got non-address dvalue"
        end

      | Store dv v =>
        match dv with
        | DVALUE_Addr (b, i) =>
          match lookup b m with
          | Some m' =>
            ret ((add b (add_all_index (serialize_dvalue v) i m') m, s), tt)
          | None => raise "stored to unallocated address"
          end
        | _ => raise ("Store got non-address dvalue: " ++ (to_string dv))
        end

      | GEP t dv vs =>
        match handle_gep t dv vs m with
        | inl err => raise err
        | inr (m, dv) => ret ((m, s), dv)
        end

      | ItoP i =>
        match i with
        | DVALUE_I64 i => ret ((m, s), DVALUE_Addr (0, unsigned i))
        | DVALUE_I32 i => ret ((m, s), DVALUE_Addr (0, unsigned i))
        | DVALUE_I8 i  => ret ((m, s), DVALUE_Addr (0, unsigned i))
        | DVALUE_I1 i  => ret ((m, s), DVALUE_Addr (0, unsigned i))
        | _            => raise "Non integer passed to ItoP"
        end

      | PtoI a =>
        match a with
        | DVALUE_Addr (b, i) =>
          if Z.eqb b 0 then ret ((m, s), DVALUE_Addr(0, i))
          else let (k, m) := concretize_block b m in
               ret ((m, s), DVALUE_Addr (0, (k + i)))
        | _ => raise "PtoI got non-address dvalue"
        end
      end.

  Definition handle_intrinsic {E} `{FailureE -< E}: IntrinsicE ~> stateT memory_stack (itree E) :=
    fun _ e '(m, s) =>
      match e with
      | Intrinsic t name args =>
        if string_dec name "llvm.memcpy.p0i8.p0i8.i32" then  (* FIXME: use reldec typeclass? *)
          match handle_memcpy args m with
          | inl err => raise err
          | inr m' => ret ((m', s), DVALUE_None)
          end
        else
            raise ("Unknown intrinsic: " ++ name)
      end.

  (* TODO: clean this up *)
  (* {E} `{failureE -< E} : IO ~> stateT memory (itree E)  *)
  (* Won't need to be case analysis, just passes through failure + debug *)
  (* Might get rid of this one *)
  (* This can't show that IO ∉ E :( *)
  (* Alternative 2: Fix order of effects

   Layer interpretors so that they each chain into the next. Have to
   do ugly matches everywhere :(.

   Split the difference:

   `{IO -< IO +' failureE +' debugE}

   Alternative 3: follow 2, and then use notations to make things better.

   Alternative 4: Extend itrees mechanisms with some kind of set operations.

   If you want to allow sums on the left of your handlers, you want
   this notion of an atomic handler / event, which is different from a
   variable or a sum...

   `{E +' F -< G}

   This seems too experimental to try to work out now --- chat with Li-yao about it.

   Alternative 2 might be the most straightforward way to get things working in the short term.

   We just want to get everything hooked together to build and test
   it. Then think about making the interfaces nicer. The steps to alt
   2, start with LLVM1 ordering as the basic default. Then each stage
   of interpretation peels off one, or reintroduces the same kind of
   events / changes it.

   *)
  Section PARAMS.
  Variable (E F : Type -> Type).
    Definition E_trigger {M} : forall R, E R -> (stateT M (itree (E +' F)) R) :=
      fun R e m => r <- trigger e ;; ret (m, r).

  Definition F_trigger {M} : forall R, F R -> (stateT M (itree (E +' F)) R) :=
      fun R e m => r <- trigger e ;; ret (m, r).

  Definition interp_memory `{FailureE -< E +' F} `{UBE -< E +' F}:
    itree (E +'  IntrinsicE +' MemoryE +' F) ~> stateT memory_stack (itree (E +' F)) :=
    interp_state (case_ E_trigger (case_ handle_intrinsic (case_ handle_memory F_trigger))).

  End PARAMS.

End Make.


Require Import ExtLib.Core.RelDec.

Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Lambda.ExprSubst.
Require Import MirrorCore.Lambda.ExprUnify_simul.
Require Import MirrorCore.Lambda.ExprVariables.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.
Require Import MirrorCore.VariablesI.

Require Import Charge.Tactics.OrderedCanceller.
Require Import Charge.Tactics.BILNormalize.
Require Import Charge.Tactics.SynSepLog.
Require Import Charge.Tactics.SepLogFoldWithAnd.
Require Import Charge.ModularFunc.ILogicFunc.
Require Import Charge.ModularFunc.BILogicFunc.

Set Implicit Arguments.
Set Strict Implicit.

Section Canceller.
  Context (typ func subst : Type) (tyLogic : typ).
  Context {HIL : ILogicFunc typ func} {HBIL : BILogicFunc typ func}.
  Context {RType_typ : RType typ} {RelDec_typ : RelDec (@eq typ)}.
  Context {Typ2_typ : Typ2 RType_typ Fun}.
  Context {RSym_func : @RSym _ RType_typ func}.
  Existing Instance Expr_expr.
  Context {SS : Subst subst (expr typ func)}.
  Context {SU : SubstUpdate subst (expr typ func)}.
  Context {SO : SubstOk SS}.
  Context {MA : MentionsAny (expr typ func)}.
  Context {uis_pure : expr typ func -> bool}.

  Definition sls : SepLogAndSpec typ func :=
  {| is_pure := fun e : expr typ func =>
                  match ilogicS e with
		    | Some (ilf_true _)
		    | Some (ilf_false _) => true
		    | _ => uis_pure e
		  end
   ; is_emp := fun e => false
   ; is_star := fun e : expr typ func =>
 		  match bilogicS e with
 		    | Some (bilf_star _) => true
 		    | _ => false
 		  end
   ; is_and := fun e : expr typ func =>
 		  match ilogicS e with
 		    | Some (ilf_and _) => true
 		    | _ => false
 		  end
   |}.

  Let doUnifySepLog c (tus tvs : EnvI.tenv typ) (s : ctx_subst (typ := typ) (expr := expr typ func) c) (e1 e2 : expr typ func)
  : option (ctx_subst c) :=
    @exprUnify (ctx_subst c) typ func RType_typ RSym_func Typ2_typ _ _ 10 tus tvs 0 e1 e2 tyLogic s.

  Let ssl : SynSepLog typ func :=
  {| e_star := fun l r =>
                 match bilogicS l with
                   | Some (bilf_emp _) => r
                   | _ => match bilogicS r with
                            | Some (bilf_emp _) => l
                            | _ => mkStar tyLogic l r
                          end
                 end
   ; e_emp := mkEmp tyLogic
   ; e_and := fun l r =>
                match ilogicS l with
                  | Some (ilf_true _) => r
                  | _ => match ilogicS r with
                           | Some (ilf_true _) => l
                           | _ => mkAnd tyLogic l r
                         end
                end
   ; e_true := mkTrue tyLogic
   |}.

  Definition eproveTrue c (s : ctx_subst (typ := typ) (expr := expr typ func) c) (e : expr typ func) : option (ctx_subst c) :=
    match ilogicS e with
      | Some (ilf_true _) => Some s
      | _ => None
    end.

  Definition is_solved (e1 e2 : conjunctives typ func) : bool :=
    match e1 , e2 with
      | {| spatial := e1s ; star_true := t ; pure := _ |}
        , {| spatial := nil ; star_true := t' ; pure := nil |} =>
        if t' then
          (** ... |- true **)
          true
        else
          (** ... |- emp **)
          if t then false else match e1s with
                                 | nil => true
                                 | _ => false
                               end
      | _ , _ => false
    end.
Check @OrderedCanceller.ordered_cancel.

  Definition the_canceller tus tvs (lhs rhs : expr typ func) c
             (s : ctx_subst c)
  : (expr typ func * expr typ func * (ctx_subst c)) + (ctx_subst c) :=
    match @normalize_and typ _ _ func _ ssl sls tus tvs tyLogic lhs
        , @normalize_and typ _ _ func _ ssl sls tus tvs tyLogic rhs
    with
      | Some lhs_norm , Some rhs_norm =>
        match lhs_norm tt , rhs_norm tt with
          | Some lhs_norm , Some rhs_norm =>
            let '(lhs',rhs',s') :=
                OrderedCanceller.ordered_cancel (subst := ctx_subst c)
                  (doUnifySepLog (c := c) tus tvs) (eproveTrue (c := c))
                  ssl
                  (simple_order (func:=func)) lhs_norm rhs_norm s
            in
            if is_solved lhs' rhs' then
              inr s'
            else
              inl (conjunctives_to_expr ssl lhs',
                   conjunctives_to_expr ssl rhs',
                   s')
          | _ , _ => inl (lhs, rhs, s)
        end
      | _ , _ => inl (lhs, rhs, s)
    end.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Definition CANCELLATION : rtac typ (expr typ func) :=
    fun tus tvs nus nvs c s e =>
      match e with
        | App (App f L) R =>
          match ilogicS f with
	    | Some (ilf_entails t) =>
	      match t ?[ eq ] tyLogic with
	     	| true =>
		  match the_canceller tus tvs L R s with
		    | inl (l,r,s') =>
		      match bilogicS r with (* This is for intuitionistic logics only *)
		        | Some (bilf_emp _) => Solved s'
		        | _ => let e' := mkEntails tyLogic l r in
			       More s (GGoal e')
		      end
		    | inr s' => Solved s'
		  end
		| false => More s (GGoal e)
	      end
	    | _ => More s (GGoal e)
	  end
        | _ => More s (GGoal e)
      end.

Definition the_canceller2 tus tvs (lhs rhs : expr typ func) :=
    match @normalize_and typ _ _ func _ ssl sls tus tvs tyLogic lhs
        , @normalize_and typ _ _ func _ ssl sls tus tvs tyLogic rhs
    with
      | Some lhs_norm , Some rhs_norm =>
        match lhs_norm tt , rhs_norm tt with
          | Some lhs_norm , Some rhs_norm =>
            Some (simple_order (func := func) lhs_norm,
                  simple_order (func := func) rhs_norm)
          | _ , _ => None
        end
      | _ , _ => None
    end.

  Definition CANCELLATION2 tus tvs e :=
      match e with
        | App (App f L) R =>
          match ilogicS f with
	    | Some (ilf_entails t) =>
	      match t ?[ eq ] tyLogic with
	     	| true => the_canceller2 tus tvs L R
		    | false => None
	      end
	    | _ => None
	  end
        | _ => None
      end.

End Canceller.

Implicit Arguments CANCELLATION [[HIL] [HBIL] [RType_typ] [RelDec_typ]
                                [Typ2_typ] [RSym_func] [MA]].


Require Import String.

(* Require Import Setoid. *)
(* Require Import Coq.Arith.PeanoNat. *)
(* Require Import Coq.Logic.Decidable. *)

From networks Require Import listidx.
From networks Require Import sequences.

Set Implicit Arguments.

Variable nodeCount : nat.
Definition node := { n:nat | n < nodeCount}.
Definition label := nat.

Section modules.

Variant module_io_t ( I O : Type) :=
    | m_evt_in : label -> node -> I -> module_io_t I O
    | m_evt_out : label -> node -> O -> module_io_t I O
.

#[global]Arguments m_evt_in [I O]%type_scope _ _ _.
#[global]Arguments m_evt_out [I O]%type_scope _ _ _.

Inductive corruption_evt   :=
    | corruption : node -> corruption_evt
.

Record module : Type :=  {
    l : label;
    I : Type;
    O : Type;
    module_io : Type := module_io_t I O;
    module_xioc : Type := unit + module_io + corruption_evt;
    A : seq module_xioc -> Prop
}.

End modules.

Section StateMachines.

Open Scope type_scope.

Record stateMachine (I O : Type) :Type := {
    State : Type;
    S0 : State;
    transition : State -> I -> ( O * State )
}.

End StateMachines.

Section Protocols.

Variant protocol_io_t (I O : Type) :=
    | p_evt_in : node -> I -> protocol_io_t I O
    | p_evt_out : node -> O -> protocol_io_t I O
.

#[global]Arguments p_evt_in [I]%type_scope [O]%type_scope _ _.
#[global]Arguments p_evt_out [I]%type_scope [O]%type_scope _ _.

Variant exec_evt_t  (I O : Type) (M: list module)  :=
    | prot : protocol_io_t I O -> exec_evt_t I O M
    | mod (m : listidx.indexOf M) : module_io (nth_checked m) -> exec_evt_t I O M
    | corr : corruption_evt -> exec_evt_t I O M
.

#[global]Arguments prot [I O]%type_scope [M]%list_scope _.
#[global]Arguments mod [I O]%type_scope [M]%list_scope m _.
#[global]Arguments corr [I O]%type_scope [M]%list_scope _.
(*
 Definition in_SMI_t (I O : Type) (M: list module) (e:exec_evt_t I O M) : Prop :=
    match e with
        | prot (p_evt_in _ _) | mod _ (m_evt_out _ _ _) => True
        | _ => False
    end.

Definition in_SMO_t (I O : Type) (M: list module) (e:exec_evt_t I O M) : Prop :=
    match e with
        | prot (p_evt_out _ _) | mod _ (m_evt_in _ _ _) => True
        | _ => False
    end. *)

Record Protocol := {
    Ip : Type;
    Op : Type;
    M : list module;
    protocol_io := protocol_io_t Ip Op;
    exec_evt := exec_evt_t Ip Op M;
    prot_p := prot (I:=Ip) (O:=Op) (M:=M);
    module_p := mod (I:=Ip) (O:=Op) (M:=M);
    corr_p := corr (I:=Ip) (O:=Op) (M:=M);
    (* inSMI := in_SMI_t (I:=Ip) (O:=Op) (M:=M);
    inSMO := in_SMO_t (I:=Ip) (O:=Op) (M:=M); *)

    (* all definitions required to define the state machine I/O types needs to be inlined within the record def*)
    inSMI := fun (e:exec_evt) => match e with
                | prot (p_evt_in _ _) | mod _ (m_evt_out _ _ _) => True
                | _ => False
            end;
    inSMO := fun (e : exec_evt) =>  match e with
                | prot (p_evt_out _ _) | mod _ (m_evt_in _ _ _) => True
                | _ => False
              end;
    SMI := {e:exec_evt | inSMI e};
    SMO := list {e:exec_evt | inSMO e};
    SM : stateMachine SMI SMO;
}.

(* in view of p means it's an input/output of p  *)
Definition isInNodeView (P:Protocol) (e:exec_evt P) (p:node) : Prop :=
    match e with
        | prot (p_evt_in p _)  | mod _ (m_evt_out _ p _)
        | prot (p_evt_out p _) | mod _ (m_evt_in _ p _)  => True
        | _ => False
end.

Lemma view_subset_SMIO (P:Protocol) (e:exec_evt P) (p:node) : isInNodeView e p -> {inSMI e} + {inSMO e} .
Proof.
    intros. unfold isInNodeView in H.
    repeat match goal with
    | s : match ?a with _ => _ end |- _ =>  destruct a
    end.
    all: simpl;auto.
Qed.

Lemma isInNodeView_dec (P:Protocol) (e:exec_evt P) (p:node) : {isInNodeView e p} + {~isInNodeView e p}.
Proof.
    unfold isInNodeView. destruct e.
    - destruct p0. all: auto.
    - destruct m0. all: auto.
    - auto.
Qed.

Lemma in_SMI_dec (P:Protocol) (e:exec_evt P) :  {inSMI e} + {~inSMI e}.
Proof.
    unfold inSMI. destruct e.
    - destruct p. all: simpl;auto.
    - destruct m0. all: simpl;auto.
    - auto.
Qed.

Definition execs (P:Protocol) := seq (exec_evt P).

Definition compatible_spec (P:Protocol) (s:module) : Prop :=
    Ip P = I s /\ Op P = O s.

Definition spec_of (P:Protocol) := { s:module | compatible_spec P s}.

Definition convert_type (I I' : Type) (p_eq : I = I') (i : I ) : I' := eq_rect I (fun X => X) i I' p_eq.
Definition convert_set (I I' : Set) (p_eq : I = I') (i : I ) : I' := eq_rect I (fun X => X) i I' p_eq.

(* convert protocol io events into its spec io events  *)
Definition convert_io {P:Protocol} (io : protocol_io P) (s: module) (comp_proof : compatible_spec P s) : module_io s :=
    match io with
        | p_evt_in  n in' => m_evt_in (l s) n (convert_type (proj1 comp_proof) in')
        | p_evt_out  n out' => m_evt_out (l s) n (convert_type (proj2 comp_proof) out')
    end.

(* convert protocol execs into sequences that can be fed to its specification admissibility predicate.  *)
CoFixpoint strip_exec (P:Protocol) (s: module) (comp_proof : compatible_spec P s) (E: execs P) : seq (module_xioc s) :=
    match E  with
        | cons  e tl => let e' := match e with
                | mod m io => inl (inl tt)
                | prot io       => inl (inr (convert_io io comp_proof))
                | corr c    => inr c
            end in cons e' (strip_exec comp_proof tl)
        | nil _     => nil (module_xioc s)
    end.

Require Import Coq.Program.Wf.

(* the sate at the nth event is the state right *before* the nth event is processed by the SM*)
(* the recursive call is bascally a destruct on (rangeproof i) *)
(* You may notice that "index i = n" is unused. It is present to make it appear as an hypothesis of the proof of well-foundedness *)
Program Fixpoint state_at (P:Protocol) (E : execs P) (i: indexOf E) (p:node) {measure (index i)} : State (SM P) :=
    match index i as n return isinIndex E n -> index i = n -> State (SM P) with
        | 0     => fun _ _ => S0 (SM P)
        | S n'  => fun (p_in : isinIndex E (S n')) (_ : index i = (S n') ) => let prev_state := (state_at (mkIndex (skip_one p_in)) p) in
            match (in_SMI_dec (elem i)), (isInNodeView_dec (elem i) p) with  (* only process input in view *)
                | left pSMI, left pNodeView => snd (transition (SM P) prev_state (exist _ _ pSMI))
                | _, _                      => prev_state
            end
    end (rangeproof i) (eq_refl (index i)).
Next Obligation. rewrite H. auto. Defined.

Definition isNodeOut (P:Protocol) (e:exec_evt P) (p:node) : Prop :=
    match e with
    | prot (p_evt_out p _) | mod _ (m_evt_in _ p _)  => True
    | _ => False
end.

Definition isNodeIn  (P:Protocol) (e:exec_evt P) (p:node) : Prop :=
    match e with
        | prot (p_evt_in p _)  | mod _ (m_evt_out _ p _) => True
        | _ => False
end.

Lemma NodeOutEquivSMOView  (P:Protocol) (e:exec_evt P) (p:node) : isInNodeView e p /\ inSMO e <-> isNodeOut e p.
Proof.
    split. all:intros.
    - unfold isNodeOut. destruct H. unfold isInNodeView in H. unfold inSMO in H0.
        repeat match goal with
        | s : match ?a with _ => _ end |- _ =>  destruct a
        end. all: auto.
    - split. unfold isInNodeView. unfold isNodeOut in H.
        repeat match goal with
        | s : match ?a with _ => _ end |- _ =>  destruct a
        end. all:auto.
Qed.

Definition NodeOutConj (P:Protocol) {e:exec_evt P} {p:node}  (proof: isNodeOut e p) : isInNodeView e p /\ inSMO e :=  proj2 (NodeOutEquivSMOView e p) proof.

Lemma NodeInEquivSMIView  (P:Protocol) (e:exec_evt P) (p:node) : isInNodeView e p /\ inSMI e <-> isNodeIn e p.
split. all:intros.
- unfold isNodeIn. destruct H. unfold isInNodeView in H. unfold inSMI in H0.
    repeat match goal with
    | s : match ?a with _ => _ end |- _ =>  destruct a
    end. all: auto.
- split. unfold isInNodeView. unfold isNodeIn in H.
    repeat match goal with
    | s : match ?a with _ => _ end |- _ =>  destruct a
    end. all:auto.
Qed.
Definition NodeInConj (P:Protocol) {e:exec_evt P} {p:node}  (proof: isNodeIn e p) : isInNodeView e p /\ inSMI e :=  proj2 (NodeInEquivSMIView e p) proof.

(*The SM output of node p' SM at event i, **before** (elem i) is processed *)
Definition process_at (P:Protocol) (E : execs P) (i: indexOf E) (p:node) (pIn : isNodeIn (elem i) p)  : list {e: exec_evt P | isNodeOut e p} :=
    fst (transition (SM P) (state_at i p) (makeSig (proj2 (NodeInConj pIn)))).

Definition process_at_asSMO (P:Protocol) (E : execs P) (i: indexOf E) (p:node) (pIn : isNodeIn (elem i) p) : SMO P :=
    (process_at i p pIn) (*? is there some implicit coercions i'm not aware of? *)
.

End Protocols.

Section Models.

Definition leibniz {T:Type} (x y : T) (p_eq: x = y) (P: T -> Type) : P y -> P x.
    intros. subst y. exact X.
Defined.

(* downcast protocol execs event into events that can be fed to mod m' admissibility predicate. All events that m cannot process is replaced by unit *)
Definition clamped_evt (P:Protocol) (m: listidx.indexOf (M P)) (e: exec_evt P)  : module_xioc (nth_checked m)  :=
    match e with
        | mod  m' mio =>  match (PeanoNat.Nat.eq_dec (listidx.index m) (listidx.index m')) with
            | left eq_proof => inl (inr  (leibniz (rangeproof_irreverant m m' eq_proof) module_io mio))
            | right _       => inl (inl tt)
        end
        | corr c => inr c
        | _        =>  inl (inl tt)
    end.

Definition  module_admissible (P:Protocol) (E:execs P) : Prop :=
    forall m: (listidx.indexOf (M P)), A (map E (clamped_evt m) ).

 Definition DelayPred := forall (P:Protocol) (E:execs P) (i:indexOf E) (p:node),  Prop.

Definition staticAdv := fun (P:Protocol) (E:execs P) (i : indexOf E)  (p:node) => True.
Definition staticAdv' : DelayPred := fun _ _ _ _ => True.

Definition  corrupt_at (P:Protocol) (E:execs P) (D: DelayPred) (i : indexOf E)  (p:node)  : Prop :=
    exists (j:indexOf E), match elem j with
        | corr (corruption p) => index j < index i /\ D P E i p
        | _ => False
        end.

Definition corrupt (P:Protocol) (E:execs P) (D: DelayPred) (p:node) : Prop :=
    exists (i : indexOf E), corrupt_at D i p.

Definition honest_at (P:Protocol) (E:execs P) (D: DelayPred) (i : indexOf E)  (p:node)  : Prop :=
    ~ corrupt_at D i p.

Definition honest (P:Protocol) (E:execs P) (D: DelayPred) (p:node)  : Prop :=
    ~ corrupt E D p.

(* honest node admissibility : when an honest node receives input, all the following events are the node output. I.e., honest nodes follows the protocol *)
Definition honest_admissible (P:Protocol) (D: DelayPred) (E:execs P) : Prop :=
    forall (i : indexOf E), exists (p:node), forall pIn : (isNodeIn (elem i) p), honest_at D i p ->
    isPrefixOf (List.map (proj1_sig (P:=fun x=> isNodeOut x p)) (process_at i p pIn) )
               (tail i)
.
(* note to self: in this version, the adversary is NOT authorized to reorder outputs ! may need to fix *)

Definition corruption_struct := (node -> Prop) -> Prop.

Definition k_cover (C:corruption_struct) (k:nat) :=
    exists (pi: {n:nat | n<k} -> (node->Prop)),
    forall (p: node) (pi_n: {n:nat | n<k}),
    pi pi_n p
.

Record adversary_struct : Type := {
    C : corruption_struct;
    D : DelayPred;
}.

(* respects a given corruption structure*)
Definition structure_admissible (P:Protocol) (Adv:adversary_struct) (E:execs P)  : Prop :=
    forall (i:indexOf E), (C Adv) (corrupt_at (D Adv) i)
.

(* E is part of the model of P iff all admissibility requirements are met*)
Definition model (P:Protocol) (Adv:adversary_struct) (E:execs P) : Prop :=
    module_admissible E   /\
    honest_admissible (D Adv) E /\
    structure_admissible Adv E.

Definition satisfies (P: Protocol) (Adv:adversary_struct)  (s:spec_of P) (s: module ) (comp_proof : compatible_spec P s) : Prop  :=
    forall E:execs P, model Adv E -> A (strip_exec comp_proof E)
.

End Models.


From iris Require Import base.
From iris.program_logic Require Import language ectx_language ectxi_language.
From stdpp Require Import gmap fin_maps fin_sets.
From cap_machine Require Import addr_reg.

Section Linking.

  Variable Symbols: Type.
  Variable Symbols_eq_dec: EqDecision Symbols.
  Variable Symbols_countable: Countable Symbols.

  Variable Word: Type.
  Variable can_address_only: Word -> (gset Addr) -> Prop.
  Variable is_main: Word -> Prop.

  Definition imports: Type := gset (Symbols * Addr).
  Definition exports: Type := gmap Symbols Word.
  Definition segment: Type := gmap Addr Word.

  Definition pre_component: Type := (segment * imports * exports).
  Inductive component: Type :=
  | Lib: pre_component -> component
  | Main: pre_component -> Word -> component.

  Inductive well_formed_pre_comp: pre_component -> Prop :=
  | wf_pre_intro:
      forall (ms : gmap Addr Word) imp (exp : gmap Symbols Word)
        (Hdisj: forall s, is_Some (exp !! s) -> ~ exists a, (s, a) ∈ imp)
        (Hexp: forall (s : Symbols) (w : Word), exp !! s = Some w -> can_address_only w (dom ms))
        (Himp: forall s a, (s, a) ∈ imp -> is_Some (ms !! a))
        (Himpdisj: forall s1 s2 a, (s1, a) ∈ imp -> (s2, a) ∈ imp -> s1 = s2)
        (Hnpwl: forall (a : Addr) (w : Word), ms !! a = Some w -> can_address_only w (dom ms)),
        well_formed_pre_comp (ms, imp, exp).

  Inductive well_formed_comp: component -> Prop :=
  | wf_lib:
      forall comp
        (Hwf_pre: well_formed_pre_comp comp),
        well_formed_comp (Lib comp)
  | wf_main:
      forall comp w_main
        (Hwf_pre: well_formed_pre_comp comp)
        (Hw_main_addr: can_address_only w_main (dom (comp.1.1)))
        (Hw_main: is_main w_main),
        well_formed_comp (Main comp w_main).

  Inductive is_program: component -> Prop :=
  | is_program_intro:
      forall ms imp exp w_main
        (Hnoimports: imp = ∅)
        (Hwfcomp: well_formed_comp (Main (ms, imp, exp) w_main)),
        is_program (Main (ms,imp, exp) w_main).

  Definition resolve_imports (imp: imports) (exp: exports) (ms: segment) :=
    set_fold (fun '(s, a) m => match exp !! s with Some w => <[a:=w]> m | None => m end) ms imp.

  Lemma resolve_imports_spec:
    forall imp exp ms a
      (Himpdisj: forall s1 s2 a, (s1, a) ∈ imp -> (s2, a) ∈ imp -> s1 = s2),
      ((~ exists s, (s, a) ∈ imp) ->
       (resolve_imports imp exp ms) !! a = ms !! a) /\
      (forall s, (s, a) ∈ imp ->
       (exp !! s = None /\ (resolve_imports imp exp ms) !! a = ms !! a) \/ (exists wexp, exp !! s = Some wexp /\ (resolve_imports imp exp ms) !! a = Some wexp)).
  Proof.
    intros imp exp ms a. eapply (set_fold_ind_L (fun m imp => (forall s1 s2 a, (s1, a) ∈ imp -> (s2, a) ∈ imp -> s1 = s2) -> ((~ exists s, (s, a) ∈ imp) -> m !! a = ms !! a) /\ (forall s, (s, a) ∈ imp -> (exp !! s = None /\ m !! a = ms !! a) \/ (exists wexp, exp !! s = Some wexp /\ m !! a = Some wexp))) (fun '(s, a) m => match exp !! s with Some w => <[a:=w]> m | None => m end)); eauto.
    { intros. split; auto. intros.
      eapply elem_of_empty in H0; elim H0; auto. }
    intros. destruct x. split.
    { intros. destruct (exp !! s).
      - rewrite lookup_insert_ne; auto.
        + apply H0.
          * intros. eapply H1; eapply elem_of_union; right; eauto.
          * intro Y. destruct Y as [sy Hiny].
            eapply H2. exists sy. eapply elem_of_union. right; eauto.
        + intro; subst a. eapply H2. exists s.
          eapply elem_of_union. left. eapply elem_of_singleton. reflexivity.
      - apply H0.
        + intros. eapply H1; eapply elem_of_union; right; eauto.
        + intro Y. destruct Y as [sy Hiny].
          eapply H2. exists sy. eapply elem_of_union. right; auto. }
    { intros; destruct (exp !! s) eqn:Hexp.
      - destruct (decide (f = a)).
        + subst f; rewrite lookup_insert.
          right. assert (s0 = s) as ->; eauto.
          eapply elem_of_union in H2. destruct H2.
          * generalize (proj1 (elem_of_singleton _ _) H2). inversion 1; subst; auto.
          * eapply (H1 s0 s a); [eapply elem_of_union_r; auto|eapply elem_of_union_l; eapply elem_of_singleton; eauto].
        + rewrite lookup_insert_ne; auto.
          eapply elem_of_union in H2; destruct H2.
          * erewrite elem_of_singleton in H2. inversion H2; congruence.
          * eapply H0; auto.
            intros; eapply H1; eapply elem_of_union; right; eauto.
      - eapply elem_of_union in H2. destruct H2.
        + erewrite elem_of_singleton in H2. inversion H2; subst; clear H2.
          left; split; auto. eapply (proj1 (H0 ltac:(intros; eapply H1; eapply elem_of_union; right; eauto))).
          intro Y. destruct Y as [sy Hsy].
          eapply H. replace s with sy; auto.
          eapply H1; [eapply elem_of_union_r; eauto| eapply elem_of_union_l; eapply elem_of_singleton; eauto].
        + eapply H0; auto.
          intros; eapply H1; eapply elem_of_union_r; eauto. }
  Qed.

  Lemma resolve_imports_spec_in:
    forall imp exp ms a s
      (Himpdisj: forall s1 s2 a, (s1, a) ∈ imp -> (s2, a) ∈ imp -> s1 = s2),
      (s, a) ∈ imp ->
      (exp !! s = None /\ (resolve_imports imp exp ms) !! a = ms !! a) \/ (exists wexp, exp !! s = Some wexp /\ (resolve_imports imp exp ms) !! a = Some wexp).
  Proof.
    intros. eapply resolve_imports_spec; eauto.
  Qed.

  Lemma resolve_imports_spec_not_in:
    forall imp exp ms a
      (Himpdisj: forall s1 s2 a, (s1, a) ∈ imp -> (s2, a) ∈ imp -> s1 = s2),
      ((~ exists s, (s, a) ∈ imp) ->
       (resolve_imports imp exp ms) !! a = ms !! a).
  Proof.
    intros. eapply resolve_imports_spec; eauto.
  Qed.

  Inductive link_pre_comp: pre_component -> pre_component -> pre_component -> Prop :=
  | link_pre_comp_intro:
      forall ms1 ms2 ms imp1 imp2 imp exp1 exp2 exp
        (Hms_disj: forall a, is_Some (ms1 !! a) -> is_Some (ms2 !! a) -> False)
        (Hexp: exp = merge (fun o1 o2 => match o1 with | Some _ => o1 | None => o2 end) exp1 exp2)
        (Himp: forall s a, (s, a) ∈ imp <-> (((s, a) ∈ imp1 \/ (s, a) ∈ imp2) /\ exp !! s = None))
        (Hms: ms = resolve_imports imp2 exp (resolve_imports imp1 exp (map_union ms1 ms2))),
        link_pre_comp (ms1, imp1, exp1) (ms2, imp2, exp2) (ms, imp, exp).

  Inductive link: component -> component -> component -> Prop :=
  | link_lib_lib:
      forall comp1 comp2 comp
        (Hlink: link_pre_comp comp1 comp2 comp)
        (Hwf_l: well_formed_comp (Lib comp1))
        (Hwf_r: well_formed_comp (Lib comp2)),
        link (Lib comp1) (Lib comp2) (Lib comp)
  | link_lib_main:
      forall comp1 comp2 comp w_main
        (Hlink: link_pre_comp comp1 comp2 comp)
        (Hwf_l: well_formed_comp (Lib comp1))
        (Hwf_r: well_formed_comp (Main comp2 w_main)),
        link (Lib comp1) (Main comp2 w_main) (Main comp w_main)
  | link_main_lib:
      forall comp1 comp2 comp w_main
        (Hlink: link_pre_comp comp1 comp2 comp)
        (Hwf_l: well_formed_comp (Main comp1 w_main))
        (Hwf_r: well_formed_comp (Lib comp2)),
        link (Main comp1 w_main) (Lib comp2) (Main comp w_main).

  Inductive is_context (c comp p: component): Prop :=
  | is_context_intro:
      forall (His_program: link c comp p /\ is_program p),
      is_context c comp p.

End Linking.


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

Local Open Scope Z_scope.

Section Spec.

  Definition psci_features_spec (rec: Pointer) (psci_func_id: Z) (adt: RData) : option RData :=
	  if (psci_func_id =? SMC32_PSCI_CPU_SUSPEND)
       || (psci_func_id =? SMC64_PSCI_CPU_SUSPEND)
       || (psci_func_id =? SMC32_PSCI_CPU_OFF)
       || (psci_func_id =? SMC32_PSCI_CPU_ON)
       || (psci_func_id =? SMC64_PSCI_CPU_ON)
       || (psci_func_id =? SMC32_PSCI_AFFINITY_INFO)
       || (psci_func_id =? SMC64_PSCI_AFFINITY_INFO)
       || (psci_func_id =? SMC32_PSCI_SYSTEM_OFF)
       || (psci_func_id =? SMC32_PSCI_SYSTEM_RESET)
       || (psci_func_id =? SMC32_PSCI_FEATURES)
    then
      Some adt {priv : (priv adt) {psci_x0 : 0}}
    else
      Some adt {priv : (priv adt) {psci_x0 :  PSCI_RETURN_NOT_SUPPORTED}}.

End Spec.