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

(** RTL function inlining *)

Require Import Coqlib.
Require Import Wfsimpl.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Op.
Require Import Registers.
Require Import RTL.

(** ** Environment of inlinable functions *)

(** We maintain a mapping from function names to their definitions.
  In this mapping, we only include internal functions that are eligible for
  inlining, as determined by the external heuristic
  [should_inline]. *)

Definition funenv : Type := PTree.t function.

Definition size_fenv (fenv: funenv) := PTree_Properties.cardinal fenv.

Parameter should_inline: ident -> function -> bool.

Definition add_globdef (fenv: funenv) (idg: ident * globdef fundef unit) : funenv :=
  match idg with
  | (id, Gfun (Internal f)) =>
      if should_inline id f
      then PTree.set id f fenv
      else PTree.remove id fenv
  | (id, _) =>
      PTree.remove id fenv
  end.

Definition funenv_program (p: program) : funenv :=
  List.fold_left add_globdef p.(prog_defs) (PTree.empty function).

(** State monad *)

(** To construct incrementally the CFG of a function after inlining,
  we use a state monad similar to that used in module [RTLgen].
  It records the current state of the CFG, plus counters to generate
  fresh pseudo-registers and fresh CFG nodes.  It also records the
  stack size needed for the inlined function. *)

Record state : Type := mkstate {
  st_nextreg: positive;                 (**r last used pseudo-register *)
  st_nextnode: positive;                (**r last used CFG node *)
  st_code: code;                        (**r current CFG  *)
  st_stksize: Z                         (**r current stack size *)
}.

(** Monotone evolution of the state. *)

Inductive sincr (s1 s2: state) : Prop :=
  Sincr (NEXTREG: Ple s1.(st_nextreg) s2.(st_nextreg))
        (NEXTNODE: Ple s1.(st_nextnode) s2.(st_nextnode))
        (STKSIZE: s1.(st_stksize) <= s2.(st_stksize)).

Remark sincr_refl: forall s, sincr s s.
Proof.
  intros; constructor; xomega.
Qed.

Lemma sincr_trans: forall s1 s2 s3, sincr s1 s2 -> sincr s2 s3 -> sincr s1 s3.
Proof.
  intros. inv H; inv H0. constructor; xomega.
Qed.

(** Dependently-typed state monad, ensuring that the final state is
  greater or equal (in the sense of predicate [sincr] above) than
  the initial state. *)

Inductive res {A: Type} {s: state}: Type := R (x: A) (s': state) (I: sincr s s').

Definition mon (A: Type) : Type := forall (s: state), @res A s.

(** Operations on this monad. *)

Definition ret {A: Type} (x: A): mon A :=
  fun s => R x s (sincr_refl s).

Definition bind {A B: Type} (x: mon A) (f: A -> mon B): mon B :=
  fun s1 => match x s1 with R vx s2 I1 =>
              match f vx s2 with R vy s3 I2 =>
                R vy s3 (sincr_trans s1 s2 s3 I1 I2)
              end
            end.

Notation "'do' X <- A ; B" := (bind A (fun X => B))
   (at level 200, X ident, A at level 100, B at level 200).

Definition initstate :=
  mkstate 1%positive 1%positive (PTree.empty instruction) 0.

Program Definition set_instr (pc: node) (i: instruction): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition add_instr (i: instruction): mon node :=
  fun s =>
    let pc := s.(st_nextnode) in
    R pc
      (mkstate s.(st_nextreg) (Psucc pc) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_nodes (numnodes: positive): mon positive :=
  fun s =>
    R s.(st_nextnode)
      (mkstate s.(st_nextreg) (Pplus s.(st_nextnode) numnodes) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_regs (numregs: positive): mon positive :=
  fun s =>
    R s.(st_nextreg)
      (mkstate (Pplus s.(st_nextreg) numregs) s.(st_nextnode) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition request_stack (sz: Z): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) s.(st_code) (Zmax s.(st_stksize) sz))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition ptree_mfold {A: Type} (f: positive -> A -> mon unit) (t: PTree.t A): mon unit :=
  fun s =>
    R tt
      (PTree.fold (fun s1 k v => match f k v s1 return _ with R _ s2 _ => s2 end) t s)
      _.
Next Obligation.
  apply PTree_Properties.fold_rec.
  auto.
  apply sincr_refl.
  intros. destruct (f k v a). eapply sincr_trans; eauto.
Qed.

(** ** Inlining contexts *)

(** A context describes how to insert the CFG for a source function into
  the CFG for the function after inlining:
- a source instruction at PC [n] is relocated to PC [n + ctx.(dpc)];
- all pseudo-registers of this instruction are shifted by [ctx.(dreg)];
- all stack references are shifted by [ctx.(dstk)];
- "return" instructions are transformed into "return" or "move" instructions
  as governed by [ctx.(retinfo)].
*)

Record context: Type := mkcontext {
  dpc: positive;                        (**r offset for PCs *)
  dreg: positive;                       (**r offset for pseudo-regs *)
  dstk: Z;                              (**r offset for stack references *)
  mreg: positive;                       (**r max pseudo-reg number *)
  mstk: Z;                              (**r original stack block size *)
  retinfo: option(node * reg)           (**r where to branch on return *)
                                        (**r and deposit return value *)
}.

(** The following functions "shift" (relocate) PCs, registers, operations, etc. *)

Definition shiftpos (p amount: positive) := Ppred (Pplus p amount).

Definition spc (ctx: context) (pc: node) := shiftpos pc ctx.(dpc).

Definition sreg (ctx: context) (r: reg) := shiftpos r ctx.(dreg).

Definition sregs (ctx: context) (rl: list reg) := List.map (sreg ctx) rl.

Definition sros (ctx: context) (ros: reg + ident) := sum_left_map (sreg ctx) ros.

Definition sop (ctx: context) (op: operation) :=
  shift_stack_operation (Int.repr ctx.(dstk)) op.

Definition saddr (ctx: context) (addr: addressing) :=
  shift_stack_addressing (Int.repr ctx.(dstk)) addr.

(** The initial context, used to copy the CFG of a toplevel function. *)

Definition initcontext (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := 0;
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := None |}.

(** The context used to inline a call to another function. *)

Definition min_alignment (sz: Z) :=
  if zle sz 1 then 1
  else if zle sz 2 then 2
  else if zle sz 4 then 4 else 8.

Definition callcontext (ctx: context)
                      (dpc dreg nreg: positive) (sz: Z)
                      (retpc: node) (retreg: reg) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align (ctx.(dstk) + ctx.(mstk)) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := Some (spc ctx retpc, sreg ctx retreg) |}.

(** The context used to inline a tail call to another function. *)

Definition tailcontext (ctx: context) (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align ctx.(dstk) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := ctx.(retinfo) |}.

(** ** Recursive expansion and copying of a CFG *)

(** Insert "move" instructions to copy the arguments of an inlined
    function into its parameters. *)

Fixpoint add_moves (srcs dsts: list reg) (succ: node): mon node :=
  match srcs, dsts with
  | s1 :: sl, d1 :: dl =>
      do n <- add_instr (Iop Omove (s1 :: nil) d1 succ);
      add_moves sl dl n
  | _, _ =>
      ret succ
  end.

(** To prevent infinite inlining of a recursive function, when we
  inline the body of a function [f], this function is removed from the
  environment of inlinable functions and therefore becomes ineligible
  for inlining.  This decreases the size (number of entries) of the
  environment and guarantees termination.  Inlining is, therefore,
  presented as a well-founded recursion over the size of the environment. *)

Section EXPAND_CFG.

Variable fenv: funenv.

(** The [rec] parameter is the recursor: [rec fenv' P ctx f] copies
  the body of function [f], with inline expansion within, as governed
  by context [ctx].  It can only be called for function environments
  [fenv'] strictly smaller than the current environment [fenv]. *)

Variable rec: forall fenv', (size_fenv fenv' < size_fenv fenv)%nat -> context -> function -> mon unit.

(** Given a register-or-symbol [ros], can we inline the corresponding call? *)

Inductive inline_decision (ros: reg + ident) : Type :=
  | Cannot_inline
  | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f).

Program Definition can_inline (ros: reg + ident): inline_decision ros :=
  match ros with
  | inl r => Cannot_inline _
  | inr id => match fenv!id with Some f => Can_inline _ id f _ _ | None => Cannot_inline _ end
  end.

(** Inlining of a call to function [f].  An appropriate context is
  created, then the CFG of [f] is recursively copied, then moves
  are inserted to copy the arguments of the call to the parameters of [f]. *)

Definition inline_function (ctx: context) (id: ident) (f: function)
                           (P: PTree.get id fenv = Some f)
                           (args: list reg)
                           (retpc: node) (retreg: reg) : mon node :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := callcontext ctx dpc dreg nreg f.(fn_stacksize) retpc retreg in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** Inlining of a tail call to function [f].  Similar to [inline_function],
  but the new context is different. *)

Definition inline_tail_function (ctx: context) (id: ident) (f: function)
                               (P: PTree.get id fenv = Some f)
                               (args: list reg): mon node :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := tailcontext ctx dpc dreg nreg f.(fn_stacksize) in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** The instruction generated for a [Ireturn] instruction found in an
  inlined function body. *)

Definition inline_return (ctx: context) (or: option reg) (retinfo: node * reg) :=
  match retinfo, or with
  | (retpc, retreg), Some r => Iop Omove (sreg ctx r :: nil) retreg retpc
  | (retpc, retreg), None   => Inop retpc
  end.

(** Expansion and copying of an instruction.  For most instructions,
  its registers and successor PC are shifted as per the context [ctx],
  then the instruction is inserted in the final CFG at its final position
  [spc ctx pc].

  [Icall] instructions are either replaced by a "goto" to the expansion
  of the called function, or shifted as described above.

  [Itailcall] instructions are similar, with one additional case.  If
  the [Itailcall] occurs in the body of an inlined function, and
  cannot be inlined itself, it must be turned into an [Icall]
  instruction that branches to the return point of the inlined
  function.

  Finally, [Ireturn] instructions within an inlined function are
  turned into a "move" or "goto" that stores the result, if any,
  into the destination register, then branches back to the successor
  of the inlined call. *)

Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit :=
  match i with
  | Inop s =>
      set_instr (spc ctx pc) (Inop (spc ctx s))
  | Iop op args res s =>
      set_instr (spc ctx pc)
                (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Iload chunk addr args dst s =>
      set_instr (spc ctx pc)
                (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s))
  | Istore chunk addr args src s =>
      set_instr (spc ctx pc)
                (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s))
  | Icall sg ros args res s =>
      match can_inline ros with
      | Cannot_inline =>
          set_instr (spc ctx pc)
                    (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s))
      | Can_inline id f P Q =>
          do n <- inline_function ctx id f Q args s res;
          set_instr (spc ctx pc) (Inop n)
      end
  | Itailcall sg ros args =>
      match can_inline ros with
      | Cannot_inline =>
          match ctx.(retinfo) with
          | None =>
              set_instr (spc ctx pc)
                        (Itailcall sg (sros ctx ros) (sregs ctx args))
          | Some(rpc, rreg) =>
              set_instr (spc ctx pc)
                        (Icall sg (sros ctx ros) (sregs ctx args) rreg rpc)
          end
      | Can_inline id f P Q =>
          do n <- inline_tail_function ctx id f Q args;
          set_instr (spc ctx pc) (Inop n)
      end
  | Ibuiltin ef args res s =>
      set_instr (spc ctx pc)
                (Ibuiltin ef (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Icond cond args s1 s2 =>
      set_instr (spc ctx pc)
                (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2))
  | Ijumptable r tbl =>
      set_instr (spc ctx pc)
                (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl))
  | Ireturn or =>
      match ctx.(retinfo) with
      | None =>
          set_instr (spc ctx pc) (Ireturn (option_map (sreg ctx) or))
      | Some rinfo =>
          set_instr (spc ctx pc) (inline_return ctx or rinfo)
      end
  end.

(** The expansion of a function [f] iteratively expands all its
  instructions, after recording how much stack it needs. *)

Definition expand_cfg_rec (ctx: context) (f: function): mon unit :=
  do x <- request_stack (ctx.(dstk) + ctx.(mstk));
  ptree_mfold (expand_instr ctx) f.(fn_code).

End EXPAND_CFG.

(** Here we "tie the knot" of the recursion, taking the fixpoint
  of [expand_cfg_rec]. *)

Definition expand_cfg := Fixm size_fenv expand_cfg_rec.

(** Start of the recursion: copy and inline function [f] in the
  initial context. *)

Definition expand_function (fenv: funenv) (f: function): mon context :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx := initcontext dpc dreg nreg f.(fn_stacksize) in
  do x <- expand_cfg fenv ctx f;
  ret ctx.

(** ** Inlining in functions and whole programs. *)

Local Open Scope string_scope.

(** Inlining can increase the size of the function's stack block.  We must
  make sure that the new size does not exceed [Int.max_unsigned], otherwise
  address computations within the stack would overflow and produce incorrect
  results. *)

Definition transf_function (fenv: funenv) (f: function) : Errors.res function :=
  let '(R ctx s _) := expand_function fenv f initstate in
  if zlt s.(st_stksize) Int.max_unsigned then
    OK (mkfunction f.(fn_sig)
                   (sregs ctx f.(fn_params))
                   s.(st_stksize)
                   s.(st_code)
                   (spc ctx f.(fn_entrypoint)))
  else
    Error(msg "Inlining: stack too big").

Definition transf_fundef (fenv: funenv) (fd: fundef) : Errors.res fundef :=
  AST.transf_partial_fundef (transf_function fenv) fd.

Definition transf_program (p: program): Errors.res program :=
  let fenv := funenv_program p in
  AST.transform_partial_program (transf_fundef fenv) p.


From iris.base_logic Require Export gen_heap.
From iris.program_logic Require Export language ectx_language ectxi_language.
From iris.proofmode Require Import tactics.
From mwp Require Export mwp mwp_triple.
From mwp.mwp_modalities Require Export mwp_step_fupd mwp_fupd.
From logrel_ifc.lambda_sec Require Export lang lattice.

Class secG_un Σ := SecG_un {
  secG_un_invG :> invG Σ;
  secG_un_gen_heapG :> gen_heapG loc val Σ;
}.

Tactic Notation "umods" := rewrite /mwpC_modality /mwpD_modality; cbn.

Ltac inv_head_step :=
  repeat match goal with
         | _ => progress simplify_map_eq/= (* simplify memory stuff *)
         | H : to_val _ = Some _ |- _ => apply of_to_val in H
         | H : head_step ?e _ _ _ _ _ |- _ =>
           try (is_var e; fail 1);
           inversion H; subst; clear H
         end.

Local Hint Extern 1 (head_step _ _ _ _ _ _) => econstructor : core.
Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _, _; simpl : core.
Local Hint Resolve to_of_val : core.

Local Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto.
Local Ltac solve_exec_puredet := simpl; intros; by inv_head_step.
Local Ltac solve_pure_exec :=
  unfold IntoVal in *;
  repeat match goal with H : AsVal _ |- _ => destruct H as [??] end; subst;
  intros ?; apply nsteps_once, pure_head_step_pure_step;
  constructor; [solve_exec_safe | solve_exec_puredet].

Global Instance pure_lam e1 e2 `{!AsVal e2} :
  PureExec True 1 (App (Lam e1) e2) e1.[e2 /].
Proof. solve_pure_exec. Qed.

Global Instance pure_LetIn e1 e2 `{!AsVal e1} :
  PureExec True 1 (LetIn e1 e2) e2.[e1 /].
Proof. solve_pure_exec. Qed.

Global Instance pure_seq e1 e2 `{!AsVal e1} :
  PureExec True 1 (Seq e1 e2) e2.
Proof. solve_pure_exec. Qed.

Global Instance pure_binop op a b :
  PureExec True 1 (BinOp op (Nat a) (Nat b)) (# (binop_eval op a b)).
Proof. solve_pure_exec. Qed.

Global Instance pure_if_true e1 e2 :
  PureExec True 1 (If (Bool true) e1 e2) e1.
Proof. solve_pure_exec. Qed.

Global Instance pure_if_false e1 e2 :
  PureExec True 1 (If (Bool false) e1 e2) e2.
Proof. solve_pure_exec. Qed.

Global Instance pure_fst e1 e2 `{!AsVal e1, !AsVal e2} :
  PureExec True 1 (Proj1 (Pair e1 e2)) e1.
Proof. solve_pure_exec. Qed.

Global Instance pure_snd e1 e2 `{!AsVal e1, !AsVal e2} :
  PureExec True 1 (Proj2 (Pair e1 e2)) e2.
Proof. solve_pure_exec. Qed.

Global Instance pure_case_inl e0 e1 e2 `{!AsVal e0}:
  PureExec True 1 (Case (InjL e0) e1 e2) e1.[e0/].
Proof. solve_pure_exec. Qed.

Global Instance pure_case_inr e0 e1 e2 `{!AsVal e0}:
  PureExec True 1 (Case (InjR e0) e1 e2) e2.[e0/].
Proof. solve_pure_exec. Qed.

Global Instance pure_case_tapp e :
  PureExec True 1 (TApp (TLam e)) e.
Proof. solve_pure_exec. Qed.

Global Instance pure_case_tlapp e :
  PureExec True 1 (TLApp (TLLam e)) e.
Proof. solve_pure_exec. Qed.

Global Instance pure_unpackpack e1 e2 `{!AsVal e1}:
  PureExec True 1 (Unpack (Pack e1) e2) (e2.[e1/]).
Proof. solve_pure_exec. Qed.

Global Instance pure_fold e `{!AsVal e}:
  PureExec True 1 (Unfold (Fold e)) e.
Proof. solve_pure_exec. Qed.

Notation "l ↦{ dq } v" := (mapsto (L:=loc) (V:=val) l dq v%V)
  (at level 20, format "l  ↦{ dq }  v") : bi_scope.
Notation "l ↦{# q } v" := (mapsto (L:=loc) (V:=val) l (DfracOwn q) v%V)
  (at level 20, format "l  ↦{# q }  v") : bi_scope.
Notation "l ↦ v" := (mapsto (L:=loc) (V:=val) l (DfracOwn 1) v%V)
  (at level 20, format "l  ↦  v") : bi_scope.

Section mwp_lang_lemmas.
  Context `{secG_un Σ}.

  Definition SI (σ : state) : iProp Σ := gen_heap_interp σ.

  Lemma mwp_fupd_alloc E v Φ :
    {{| ∀ l, l ↦ v -∗ Φ (LocV l) 1 |}}@{mwpd_fupd SI}
      Alloc (# v) @ E
    {{| w ; n, Φ w n |}}.
  Proof.
    iIntros "_ !> HΦ".
    iApply mwp_fupd_lift_atomic_head_step'; auto.
    { intros []; inversion 1; eauto. }
    iIntros (σ1) "Hσ1".
    iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver.
    iModIntro. iIntros (v' σ2 Hstep); inv_head_step.
    assert (# v' = # (LocV l)) by auto; simplify_eq.
    iMod (@gen_heap_alloc with "Hσ1") as "(Hσ & Hl & _)"; first done.
    iMod "Hclose"; iModIntro; iFrame; iModIntro.
    by iApply "HΦ".
  Qed.

  Lemma mwp_fupd_load E l q v Φ :
    {{| l ↦{#q} v ∗ (l ↦{#q} v -∗ Φ v 1) |}}@{mwpd_fupd SI}
      Load (Loc l) @ E
    {{| w ; n, Φ w n |}}.
  Proof.
    iIntros "_ !> [Hl HΦ]".
    iApply mwp_fupd_lift_atomic_head_step'; auto.
    { intros []; inversion 1; eauto. }
    iIntros (σ1) "Hσ1".
    iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver.
    iDestruct (@gen_heap_valid with "Hσ1 Hl") as %?.
    iModIntro. iIntros (v' σ2 Hstep); inv_head_step.
    iMod "Hclose"; iModIntro; iFrame; iModIntro.
    by iApply "HΦ".
  Qed.

  Lemma mwp_fupd_store E l v v' Φ :
    {{| l ↦ v ∗ (l ↦ v' -∗ Φ UnitV 1) |}}@{mwpd_fupd SI}
      Store (Loc l) (# v') @ E
    {{| w ; n, Φ w n |}}.
  Proof.
    iIntros "_ !> [Hl HΦ]".
    iApply mwp_fupd_lift_atomic_head_step'; auto.
    { intros []; inversion 1; eauto. }
    iIntros (σ1) "Hσ1".
    iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver.
    iModIntro. iIntros (w σ2 Hstep); inv_head_step.
    assert (# w = # UnitV) by auto; simplify_eq.
    iMod (@gen_heap_update with "Hσ1 Hl") as "[$ Hl]".
    iMod "Hclose"; iModIntro; iFrame; iModIntro.
    by iApply "HΦ".
  Qed.

  Lemma mwp_step_fupd_alloc E v Φ :
    {{| ▷ ∀ l, l ↦ v -∗ Φ (LocV l) 1 |}}@{mwpd_step_fupd SI}
      Alloc (# v) @ E
    {{| w ; n, Φ w n |}}.
  Proof.
    iIntros "_ !> HΦ".
    iApply mwp_step_fupd_lift_atomic_head_step'; auto.
    { intros []; inversion 1; eauto. }
    iIntros (σ1) "Hσ1".
    iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver.
    do 2 iModIntro. iIntros (v' σ2 Hstep); inv_head_step.
    assert (# v' = # (LocV l)) by auto; simplify_eq.
    iMod (@gen_heap_alloc with "Hσ1") as "(Hσ & Hl & _)"; first done.
    iMod "Hclose"; iModIntro; iFrame; iModIntro.
    by iApply "HΦ".
  Qed.

  Lemma mwp_step_fupd_load E l q v Φ :
    {{| ▷ l ↦{q} v ∗ ▷ (l ↦{q} v -∗ Φ v 1) |}}@{mwpd_step_fupd SI}
      Load (Loc l) @ E
    {{| w ; n, Φ w n |}}.
  Proof.
    iIntros "_ !> [Hl HΦ]".
    iApply mwp_step_fupd_lift_atomic_head_step'; auto.
    { intros []; inversion 1; eauto. }
    iIntros (σ1) "Hσ1".
    iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver.
    do 2 iModIntro.
    iDestruct (@gen_heap_valid with "Hσ1 Hl") as %?.
    iIntros (v' σ2 Hstep); inv_head_step.
    iMod "Hclose"; iModIntro; iFrame; iModIntro.
    by iApply "HΦ".
  Qed.

  Lemma mwp_step_fupd_store E l v v' Φ :
    {{| ▷ l ↦ v ∗ ▷ (l ↦ v' -∗ Φ UnitV 1) |}}@{mwpd_step_fupd SI}
      Store (Loc l) (# v') @ E
    {{| w ; n, Φ w n |}}.
  Proof.
    iIntros "_ !> [Hl HΦ]".
    iApply mwp_step_fupd_lift_atomic_head_step'; auto.
    { intros []; inversion 1; eauto. }
    iIntros (σ1) "Hσ1".
    iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver.
    do 2 iModIntro. iIntros (w σ2 Hstep); inv_head_step.
    assert (# w = # UnitV) by auto; simplify_eq.
    iMod (@gen_heap_update with "Hσ1 Hl") as "[$ Hl]".
    iMod "Hclose"; iModIntro; iFrame; iModIntro.
    by iApply "HΦ".
  Qed.

End mwp_lang_lemmas.


Require Import ssreflect ssrfun ssrbool.
(*Require Import Generic.lemmas Generic.wlog.
Require Import PG32.pg32_inductive PG32.pg32_spreads_packings.*)
Require Import List.
Require Import PG32.pg32_spreads_packings PG32.pg32_packings.

Lemma aux_S21 : statement_packings S21.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S21.
Lemma aux_S22 : statement_packings S22.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S22.
Lemma aux_S23 : statement_packings S23.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S23.
Lemma aux_S24 : statement_packings S24.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S24.
Lemma aux_S25 : statement_packings S25.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S25.
Lemma aux_S26 : statement_packings S26.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S26.
Lemma aux_S27 : statement_packings S27.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S27.
Lemma aux_S28 : statement_packings S28.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S28.
Lemma aux_S29 : statement_packings S29.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S29.
Lemma aux_S30 : statement_packings S30.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S30.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coq.Program.Basics.
Require Import Coq.Classes.Morphisms.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcertx.common.MemoryX.
Require Import liblayers.lib.Functor.
Require Import liblayers.lib.Monad.
Require Import liblayers.lib.Lens.
Require Export liblayers.compcertx.LiftMem.
Require Import compcert.backend.Deadcodeproof.

(** Dead code elimination requires the definition of a [magree]
    relation on memories, which is a stronger version of memory
    extension parameterized on a predicate on memory locations over
    which contents must be equal between the two memories.

    Unfortunately, it is not possible to define this predicate only
    using operations and axioms of the CompCert memory model. Thus,
    CompCert provides in [compcert.backend.DeadcodeproofImpl] an
    implementation of [magree] on the concrete implementation
    [compcert.common.Memimpl] of the memory model. It becomes then
    desirable to be able to lift this implementation along any lens to
    [Memimpl.mem].

    In this file, assuming any memory model [mem] with [magree], we
    provide a uniform way to lift [magree] along a lens to [mem].
*)

Section LIFTDERIVED.
  Context `{HW: LiftMemoryModel}.

  Context `{magree_ops: !MAgreeOps bmem}
          `{magree_prf: !MAgree bmem}.

  Global Instance lift_magree_ops:
    MAgreeOps mem
    :=
      {|
        magree m1 m2 ls := lift π (fun (bm1 bm2: bmem) => magree bm1 bm2 ls) m1 m2
      |}.

  Global Instance lift_magree:
    MAgree mem.
  Proof.
    constructor.
    lift π ma_perm.
    lift π magree_monotone.
    lift π mextends_agree.
    lift π magree_extends.
    lift π magree_loadbytes.
    lift π magree_load.
    lift π magree_storebytes_parallel.
    lift π magree_store_parallel.
    lift π magree_storebytes_left.
    lift π magree_store_left.
    lift π magree_free.
  Qed.

End LIFTDERIVED.


Require Import Coq.Strings.Ascii
        Coq.Bool.Bool
        Coq.Lists.List
        Coq.Structures.OrderedType.

Require Import
        Fiat.Narcissus.BinLib.Core
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.Compose
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Lib2.WordOpt
        Fiat.Narcissus.Lib2.NatOpt
        Fiat.Narcissus.Lib2.StringOpt
        Fiat.Narcissus.Lib2.EnumOpt
        Fiat.Narcissus.Lib2.FixListOpt
        Fiat.Narcissus.Lib2.SumTypeOpt.

Require Import
        Fiat.Common.SumType
        Fiat.Examples.Tutorial.Tutorial
        Fiat.Examples.DnsServer.DecomposeEnumField
        Fiat.QueryStructure.Automation.AutoDB
        Fiat.QueryStructure.Implementation.DataStructures.BagADT.BagADT
        Fiat.QueryStructure.Automation.IndexSelection
        Fiat.QueryStructure.Specification.SearchTerms.ListPrefix
        Fiat.QueryStructure.Automation.SearchTerms.FindPrefixSearchTerms
        Fiat.QueryStructure.Automation.MasterPlan
        Fiat.Examples.HACMSDemo.DuplicateFree
        Fiat.Examples.HACMSDemo.HACMSDemo
        Fiat.Examples.HACMSDemo.WheelSensor.

(* We first synthesize an implementation of our encoder. *)
Lemma Sharpened_encode_SensorData_Impl
  : { encode_SensorData_Impl : _ &
      forall ce (val : SensorType),
        refine (encode_SensorData_Spec val ce)
               (ret (encode_SensorData_Impl val ce))}.
Proof.
  eexists; intros; set_evars.
  unfold encode_SensorData_Spec.
  unfold compose, Bind2.
  setoid_rewrite refine_encode_enum; simplify with monad laws.
  setoid_rewrite (@refine_encode_SumType
          bin
          _
          2
          ([nat : Type; nat : Type])
          _
          (icons _
                 (icons _ (inil (A := Type))))).
  simplify with monad laws.
  simpl; rewrite app_nil_r.
  finish honing.
  simpl; f_equiv.
  simpl; repeat apply Build_prim_and; eauto;
    intros; rewrite refine_encode_nat; finish honing.
Defined.

(* Extract the synthesized encoder. *)
Definition encode_SensorData_Impl :=
  Eval simpl in projT1 Sharpened_encode_SensorData_Impl.

(* Extract its proof of correctness for good measure. *)
Lemma refine_encode_SensorData_Impl
  : forall ce (val : SensorType),
        refine (encode_SensorData_Spec val ce)
               (ret (encode_SensorData_Impl val ce)).
Proof.
  exact (projT2 Sharpened_encode_SensorData_Impl).
Qed.

Opaque encode_SensorData_Spec.

Theorem SharpenedWheelSensor :
    FullySharpened WheelSensorSpec.
Proof.
  start sharpening ADT.
  start_honing_QueryStructure'.
  (* We first insert checks for the DuplicateFree constraints.  *)
  hone method "AddSpeedSubscriber". { dropDuplicateFree. }
  hone method "AddTirePressureSubscriber". { dropDuplicateFree. }
  (* Break down the suscribers 'table' into one for each topic.  *)
  decompose_EnumField "subscribers" "topic".
  (* Select the kinds of searches each 'table' should support. *)
  chooseIndexes.
  (* Implement each method using the chosen search operations. *)
  initializer.
  insertOne.
  insertOne.
  rewrite refine_encode_SensorData_Impl; planOne.
  rewrite refine_encode_SensorData_Impl; planOne.
  (* Cleanup the synthesized methods. *)
  final_optimizations.
  (* Ensure the implementation is executable. *)
  determinize.
  (* Select concrete data structures for each table.  *)
  choose_data_structures.
  (* Some final cleanup. *)
  final_simplification.
  (* And we're done! *)
  use_this_one.
Defined.

(* We can now extract the implementation derived above. *)
Definition WheelSensorImpl := Eval simpl in projT1 SharpenedWheelSensor.
Print WheelSensorImpl.


Require Export compcert.lib.Coqlib.
Require Export compcert.lib.Integers.
Require Export compcert.common.AST.
Require Export compcert.common.Values.
Require Export compcert.common.AST.
Require Export compcert.common.Globalenvs.
Require Export compcert.common.Memdata.
Require Export compcertx.common.MemoryX. (* for storebytes_empty, free_range *)
Require Export liblayers.lib.Decision.
Require Export liblayers.logic.Structures.
Require Export liblayers.logic.LayerData.
Require Export liblayers.compcertx.CompcertStructures.
Require Export liblayers.compcertx.InitMem.
Require Export AbstractData.
Require Export MemWithData.

(** * Preliminaries *)

(** Specialize [rel_incr] to use [(≤)]. *)

Notation "'incr' p R" := (rel_incr (≤) (fun p => R) p)
  (at level 100, p at level 0, R at level 0)
  : rel_scope.

(** * Simulation relations blueprints *)

Section DEFINITION.
  Context `{Hmem: BaseMemoryModel}.
  Context {D1 D2: layerdata}.
  Local Opaque mwd_ops.

  (** ** Components *)

  (** This is the most general definition of a simulation relation
    toolkit that we use. We are given two memory models, and a carrier
    type for the relation (which generalizes [meminj]). We also have
    two basic relation components, indexed by elements of the carrier
    type: [match_mem] specifies how memory states should be related,
    whereas [match_block] specifies how block identifiers should be
    related. From these two components, it is possible to build up
    ways to relate more complex states such as [Clight.state] or
    [Asm.state]. The carrier type ensures that the constituent memory
    state, values, pointers, etc. are related in a consistent way.

    We also specify a preorder on the carrier type (which generalizes
    [inject_incr]), which [match_block] (and derived relations) should
    be consistent with. This is because the simulation diagram of some
    memory operations (namely [Mem.alloc]) use a final parameter
    [p' : param] different from the initial parameter [p : param].
    To ensure that other components of the state remain related, in
    such cases we require that [p ≤ p'].

    Finally, the relations on Compcert values ([val], [memval]) are
    built from [match_block] in nearly the same way for all of our
    simulation relations (identical values are related, as well as
    pointers with related block identifiers and identical offsets).
    But there is one aspect that differs between different simulation
    relations: with some relations we want [Vundef] and [Undef] on the
    left to be related to any values on the right (ie. be bottom
    elements), whereas for other relations we only want them to be
    related to themselves. The obvious solution is to specify for each
    relation a flag indicating which case we're in. However this is
    incompatible with composition. Consider a relation [R1] which
    relates [Vundef] to anything (flag set), and a relation [R2] which
    only relates it to itself (flag cleared). The composite relation
    [R1;R2] will relate [Vundef] to most values, but there may be a
    block b' on the right such that there is no b related to it on the
    left by [R2] (∀ b, ¬ b R2 b'). In this case [Vundef] on the left
    will not be related by [R1;R2] to [Vptr b' 0] on the right,
    because there is no intermediate value for the composition to use.
    Because of these contradictory situations, there is no
    setting for the flag that describes the composite relation
    appropriately.

    To address this, we generalize from there and split the flag into
    two part: the proposition [simrel_undef_matches_values] determines
    whether [Vundef] matches all non-pointer values, and the predicate
    [simrel_undef_matches_pointer] indicates which pointer values
    [Vundef] additionnaly matches. If some pointer are related to
    [Vundef], then non-pointer values should all be related to
    [Vundef] as well. Conversely, if [simrel_undef_matches_values] is
    set, then any block [b2] related to some block [b1] on the left by
    [match_block] should be related to [Vundef] as well. *)

  Record simrel_components :=
    {
      simrel_world: Type;
      simrel_acc :> Le simrel_world;
      simrel_undef_matches_values_bool: bool;
      simrel_undef_matches_block: simrel_world -> block -> Prop;
      simrel_new_glbl: list (ident * list AST.init_data);
      simrel_meminj: simrel_world -> meminj;
      match_mem: simrel_world -> rel (mwd D1) (mwd D2)
    }.

  Global Existing Instance simrel_acc.

  (** In what follows we declare many typeclass instances with a
    [simrel_undef_matches_*] premise. To make sure they work as
    expected, we declare them as typeclasses. We also show that
    [simrel_undef_matches_values] is decidable, since it is defined
    from a boolean. *)

  Existing Class simrel_undef_matches_block.

  Class simrel_undef_matches_values (R: simrel_components) :=
    simrel_undef_matches_values_true:
      simrel_undef_matches_values_bool R = true.

  Global Instance simrel_undef_matches_values_dec R:
    Decision (simrel_undef_matches_values R) :=
      decide_booleq _ _.

  (** ** Relations derived from [simrel_meminj] *)

  (** Compcert usually passes pointers around as separate block and
    offset arguments. Since we can't relate those independently
    (because the offset shift is specific to each block), we instead
    relate (block, offset) pairs and use [rel_curry] to construct our
    [Monotonicity} relations.

    Relating pointers is complicated because of the interaction
    between the abstract [Z] offsets that are used by the memory model
    and the [ptrofs] concrete machine representations that are used to
    build [val]ues. The basic relation [match_ptr] relates abstract
    pointers in the obvious way, while [match_ptrbits] relates
    concrete pointers as is done in [Val.inject]. *)

  Inductive match_ptr R p: relation (block * Z)%type :=
    match_ptr_intro b1 ofs1 b2 delta:
      simrel_meminj R p b1 = Some (b2, delta) ->
      match_ptr R p (b1, ofs1) (b2, ofs1 + delta)%Z.

  Inductive match_ptrbits R p: relation (block * ptrofs)%type :=
    match_ptrbits_intro b1 ofs1 b2 delta:
      simrel_meminj R p b1 = Some (b2, delta) ->
      match_ptrbits R p (b1, ofs1) (b2, Ptrofs.add ofs1 (Ptrofs.repr delta)).

  (** For [Mem.free] we need to relate a whole range of abstract
    pointers in the form of an (ofs, lo, hi) triple. *)

  Inductive match_ptrrange R p: relation (block * Z * Z)%type :=
    match_ptrrange_intro b1 ofs1 b2 ofs2 sz:
      RIntro
        (match_ptr R p (b1, ofs1) (b2, ofs2))
        (match_ptrrange R p) (b1, ofs1, ofs1+sz)%Z (b2, ofs2, ofs2+sz)%Z.

  Global Existing Instance match_ptrrange_intro.

  (** For operations that manipulate blocks, we can use the two
    relations below: the weaker [match_block] relates two blocks
    according to [simrel_meminj], no matter what the offset shift
    is. The stronger [match_block_sameofs] only relates blocks that
    correspond to one another with no shift in offset. *)

  Definition match_block R p b1 b2 :=
    exists delta, simrel_meminj R p b1 = Some (b2, delta).

  Definition match_block_sameofs R p b1 b2 :=
    simrel_meminj R p b1 = Some (b2, 0%Z).

  Lemma match_block_sameofs_match_ptr R p b1 b2 o:
    match_block_sameofs R p b1 b2 ->
    match_ptr R p (b1, o) (b2, o).
  Proof.
    intros H.
    replace o with (o + 0)%Z at 2 by omega.
    constructor.
    assumption.
  Qed.

  Lemma match_block_sameofs_match_ptrbits R p b1 b2 o:
    match_block_sameofs R p b1 b2 ->
    match_ptrbits R p (b1, o) (b2, o).
  Proof.
    intros H.
    replace o with (Ptrofs.add o Ptrofs.zero) at 2
      by (rewrite Ptrofs.add_zero; reflexivity).
    constructor.
    assumption.
  Qed.

  (** From [match_ptr] and [simrel_undef_matches_*], we can derive
    relation for [val] and [memval]. *)

  Inductive match_val R (p: simrel_world R): rel val val :=
    | match_val_int:
        Monotonic (@Vint) (- ==> match_val R p)
    | match_val_long:
        Monotonic (@Vlong) (- ==> match_val R p)
    | match_val_float:
        Monotonic (@Vfloat) (- ==> match_val R p)
    | match_val_single:
        Monotonic (@Vsingle) (- ==> match_val R p)
    | match_val_ptr_def b1 ofs1 b2 ofs2:
        match_ptrbits R p (b1, ofs1) (b2, ofs2) ->
        match_val R p (Vptr b1 ofs1) (Vptr b2 ofs2)
    | match_val_undef:
        Monotonic (@Vundef) (match_val R p)
    | match_val_undef_int i:
        simrel_undef_matches_values R ->
        Related (@Vundef) (Vint i) (match_val R p)
    | match_val_undef_long i:
        simrel_undef_matches_values R ->
        Related (@Vundef) (Vlong i) (match_val R p)
    | match_val_undef_float f:
        simrel_undef_matches_values R ->
        Related (@Vundef) (Vfloat f) (match_val R p)
    | match_val_undef_single f:
        simrel_undef_matches_values R ->
        Related (@Vundef) (Vsingle f) (match_val R p)
    | match_val_undef_ptr b ofs:
        simrel_undef_matches_block R p b ->
        Related (@Vundef) (Vptr b ofs) (match_val R p).

  Global Instance match_val_ptr R p:
    Monotonic (@Vptr) (rel_curry (match_ptrbits R p ++> match_val R p)).
  Proof.
    intros [b1 ofs1] [b2 ofs2].
    apply match_val_ptr_def.
  Qed.

  Global Existing Instance match_val_int.
  Global Existing Instance match_val_long.
  Global Existing Instance match_val_float.
  Global Existing Instance match_val_single.
  Global Existing Instance match_val_ptr.
  Global Existing Instance match_val_undef.
  Global Existing Instance match_val_undef_int.
  Global Existing Instance match_val_undef_long.
  Global Existing Instance match_val_undef_float.
  Global Existing Instance match_val_undef_single.
  Global Existing Instance match_val_undef_ptr.

  (** Note that in the [Undef] case, even though we use [match_val] we
    still need a [simrel_undef_matches_values] guard. This is because
    we want to exclude [match_memval Undef (Fragment Vundef _ _)] when
    the guard is not satisfied, otherwise for example we lose the fact
    that [match_memval id = eq]. *)

  Inductive match_memval R (p: simrel_world R): rel memval memval :=
    | match_memval_byte:
        Monotonic (@Byte) (- ==> match_memval R p)
    | match_memval_fragment:
        Monotonic (@Fragment) (match_val R p ++> - ==> - ==> match_memval R p)
    | match_memval_undef:
        Monotonic (@Undef) (match_memval R p)
    | match_memval_undef_byte b:
        simrel_undef_matches_values R ->
        Related (@Undef) (@Byte b) (match_memval R p)
    | match_memval_undef_fragment v q n:
        simrel_undef_matches_values R ->
        RIntro
          (match_val R p Vundef v)
          (match_memval R p) Undef (Fragment v q n).

  Global Existing Instance match_memval_byte.
  Global Existing Instance match_memval_fragment.
  Global Existing Instance match_memval_undef.
  Global Existing Instance match_memval_undef_byte.
  Global Existing Instance match_memval_undef_fragment.

  (** ** [simrel_option_le] *)

  (** This is a version of [option_le] sensitive to the
    [simrel_undef_matches_values] component of a given simulation
    relation. It is particularly useful in the [SimValues] library.

    Some operations are formulated in terms of intermediate [option]
    results. Often when some input is [Vundef], these intermediate
    results are set to [None]. Then [Val.of_optbool] maps [None] back
    to [Vundef]. This means that whether we want [None] to act as a
    bottom element depend on whether [Vundef] does -- [option_le] is
    in general too weak and [option_rel] is too strong. To solve this
    problem we introduce this relator, which behaves like one or the
    other depending on [simrel_undef_matches_values].

    Note that it still might be too weak in some corner cases, because
    it does not take [simrel_undef_matches_block] into account.
    Fortunately, so far this has not been an issue because it seems
    in practice [option val] is never used with pointers. The one
    function that cannot be characterized is [Val.make_total],
    fortunately it is only used in a few places where it can be worked
    around fairly easily. *)

  (** To define [simrel_option_le], we start with a more general
    [flex_option_le] parametrized with a proposition [P] which
    determines whether [None] is allowed as a bottom element. *)

  Inductive flex_option_le {A B} (P: Prop) RAB: rel (option A) (option B) :=
    | flex_option_le_some_def:
        Monotonic Some (RAB ++> flex_option_le P RAB)
    | flex_option_le_none_def:
        Monotonic None (flex_option_le P RAB)
    | flex_option_le_none_lb:
        P ->
        LowerBound (flex_option_le P RAB) None.

  Global Instance option_rel_flex_option_le_subrel {A B} P (R: rel A B):
    Related (option_rel R) (flex_option_le P R) subrel.
  Proof.
    destruct 1; constructor; auto.
  Qed.

  Global Instance flex_option_le_option_le {A B} P (R: rel A B) :
    Related (flex_option_le P R) (option_le R) subrel.
  Proof.
    destruct 1; constructor; auto.
  Qed.

  Global Existing Instance flex_option_le_none_lb.

  (** Assuming [P] is a known typeclass, [flex_option_le_none_lb] can
    be used when using [lower_bound] directly. However the path to
    [RAuto] through [Related] does not work. This is because in that
    context, the relation from the goal is not available during the
    [LowerBound] search; instead we search for a [LowerBound] instance
    for an arbitrary relation, which is lated connected to the
    relation in the goal through a [subrel] search. This works great
    with most relations, but in this case this means that at
    [LowerBound] resolution time, the value of [P] is unknown, and we
    cannot resolve the corresponding premise in [flex_option_le_none_lb].

    We can work around this issue with the following [RIntro] hint. *)

  Global Instance flex_option_le_none_lb_rintro {A B} (P: Prop) (RAB: rel A B) y:
    P ->
    RIntro True (flex_option_le P RAB) None y.
  Proof.
    intros H _.
    apply flex_option_le_none_lb.
    assumption.
  Qed.

  Global Instance flex_option_le_refl {A} P (RA: relation A):
    Reflexive RA ->
    Reflexive (flex_option_le P RA).
  Proof.
    intros HRA x.
    destruct x; constructor.
    reflexivity.
  Qed.

  Global Instance flex_option_map_rel P:
    Monotonic
      (@option_map)
      (forallr S, forallr T,
        (S ++> T) ++> flex_option_le P S ++> flex_option_le P T).
  Proof.
    unfold option_map.
    repeat rstep.
    constructor; eauto.
  Qed.

  (** For similar reasons, we will also need a corresponding version
    of [leb] to relate the results of operations such as
    [Mem.valid_pointer], which are involved in pointer comparisons. *)

  Inductive flex_leb (P: Prop) : rel bool bool :=
    | flex_leb_refl : Reflexive (flex_leb P)
    | flex_leb_false_true : P -> LowerBound (flex_leb P) false.

  Global Existing Instance flex_leb_refl.
  Global Existing Instance flex_leb_false_true.

  Instance flex_leb_leb P:
    Related (flex_leb P) leb subrel.
  Proof.
    destruct 1; reflexivity.
  Qed.

  Global Instance andb_flex_leb:
    forall P, Monotonic andb (flex_leb P ++> flex_leb P ++> flex_leb P).
  Proof.
    intros P x1 x2 Hx y1 y2 Hy.
    destruct Hx, Hy; simpl; try constructor; eauto.
    destruct x; constructor; eauto.
  Qed.

  (** Then, we use [simrel_undef_matches_values] as the parameter in
    order to obtain the behavior we want for [simrel_option_le]. We
    use a notation so that the instances defined above for
    [flex_option_le] can apply directly. *)

  Notation simrel_option_le R :=
    (flex_option_le (simrel_undef_matches_values R)).

  Notation simrel_leb R :=
    (flex_leb (simrel_undef_matches_values R)).

  (** ** Initial memory *)

  (** The [simrel_new_glbl] field is enough to formulate a sufficient
    condition on programs for the initial memory states to be related.
    Here we use [program_rel] to express this condition.

    Note that we're careful to define [simrel_program_rel] in such a
    way that, when applied to [simrel_components] which have the same
    [simrel_new_glbl] and [simrel_undef_matches_values_bool], the
    results will be convertible. This is why the components are
    parametrized by those directly, rather than by the
    [simrel_components] under consideration.

    The relation on function definitions is straightforward. If [R]
    permits [Vundef] as a bottom element, we also allow new function
    definitions to be introduced on the right-hand side. Otherwise,
    the function definitions should either both be [None], or both use
    [Some]. Since the initial memory is constructed in a way does not
    actually depend on the details of a function definition, we don't
    enforce any other requirements. *)

  Definition simrel_fundef_rel {F1 F2} b: ident -> rel (option F1) (option F2) :=
    fun _ => flex_option_le (b = true) ⊤%rel.

  (** For variables, we need to distinguish two cases depending on
    whether they're listed in [simrel_new_glbl] or not.

    If they are, then the variable must not appear on the left-hand
    side, and must appear on the right-hand side, and contain the
    specified initialization data. Note that for composition to work,
    we need to make sure that the variable does not appear twice in
    [simrel_new_glbl].  Otherwise, it would be possible to have a
    situation where [v] appears in both [R12] and [R23], and
    [None [R23 ∘ R12] (Some v)] holds as a result, but there would be
    no intermediate value [x] that would satisfy both [None [R12] x]
    and [x [R23] (Some v)].

    For variables not in [simrel_new_glbl], we allow new variables on
    the right-hand side if [simrel_undef_matches_values], and
    otherwise require that the definitions be identical. *)

  Definition test (P: Prop) `{Decision P}: bool :=
    if decide P then true else false.

  Definition simrel_new_glbl_for (ng: list (ident * list AST.init_data)) i :=
    filter (fun def => test (fst def = i)) ng.

  Definition simrel_newvar_ok ng b (i: ident) init :=
    (simrel_new_glbl_for ng i = (i, init)::nil) \/
    (simrel_new_glbl_for ng i = nil /\ b = true).

  Definition simrel_not_new_glbl ng i :=
    simrel_new_glbl_for ng i = nil.

  Inductive simrel_vardef_rel {V} ng b i: relation (option (globvar V)) :=
    | simrel_vardef_rel_none:
        simrel_not_new_glbl ng i ->
        simrel_vardef_rel ng b i None None
    | simrel_vardef_rel_some v:
        simrel_not_new_glbl ng i ->
        simrel_vardef_rel ng b i (Some v) (Some v)
    | simrel_vardef_rel_newvar v init:
        simrel_newvar_ok ng b i init ->
        Genv.init_data_list_valid find_symbol 0 init = true ->
        simrel_vardef_rel ng b i None
          (Some
             {| gvar_info := v;
                gvar_init := init;
                gvar_readonly := false;
                gvar_volatile := false |}).

  Definition simrel_program_rel {F1 F2 V} R :=
    program_rel
      (@simrel_fundef_rel F1 F2 (simrel_undef_matches_values_bool R))
      (@simrel_vardef_rel V (simrel_new_glbl R) (simrel_undef_matches_values_bool R)).

  (** ** Properties *)

  (* The expectation is that the basic relation components should be
    compatible with the basic memory operations, in a way that is
    consistent with the carrier order, as explained above.

    Although the definition below is a good start, we will also need
    to know that the builtin functions work well. One option would be
    to characterize the buitins in terms of the memory operations so
    that we can come up with a generic proof for them.

    It is also unclear how the initial memory is going to work out.
    One option would be to give a relation on programs in
    [SimulationRelationOps] (parametric in the types of function and
    variable definitions), and require a corresponding relational
    property for [Genv.init_mem].
   *)

  Class SimulationRelation R :=
    {
      (** Properties of the accessibility relation. *)

      simrel_acc_preorder:
        @PreOrder (simrel_world R) (≤);

      simrel_acc_undef_matches_pointer:
        Monotonic (simrel_undef_matches_block R) ((≤) ++> - ==> impl);

      simrel_acc_meminj:
        Monotonic (simrel_meminj R) ((≤) ++> - ==> option_le eq);

      (** Consistency of [simrel_undef_matches_values] and
        [simrel_undef_matches_block]. *)

      simrel_undef_matches_values_also_block p ptr1 b2 ofs2:
        simrel_undef_matches_values R ->
        match_ptrbits R p ptr1 (b2, ofs2) ->
        simrel_undef_matches_block R p b2;

      simrel_undef_matches_block_also_values p b2:
        simrel_undef_matches_block R p b2 ->
        simrel_undef_matches_values R;

      (** The following condition is necessary for the subtraction
          and comparison of two pointers. *)
      simrel_undef_matches_block_or_injective p b2:
        forall b1 b1',
          b1' <> b1 ->
          match_block R p b1 b2 ->
          match_block R p b1' b2 ->
          simrel_undef_matches_block R p b2;

      (* The following conditions are necessary for comparing
         invalid pointers with Val.cmpu* *)
      simrel_undef_matches_block_invalid_weak p m1 m2 b1 ofs1 b2 ofs2:
        match_mem R p m1 m2 ->
        Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = false ->
        match_ptrbits R p (b1, ofs1) (b2, ofs2) ->
        Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned ofs2) = true ->
        simrel_undef_matches_block R p b2;

      simrel_undef_matches_block_invalid p m1 m2 b1 ofs1 b2 ofs2:
        match_mem R p m1 m2 ->
        Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = false ->
        match_ptrbits R p (b1, ofs1) (b2, ofs2) ->
        Mem.valid_pointer m2 b2 (Ptrofs.unsigned ofs2) = true ->
        simrel_undef_matches_block R p b2;

      (** Properties of [match_block_delta]. *)

      match_global_block_sameofs p b:
        block_is_global b ->
        Proper (match_block_sameofs R p) b;

      (** Initial memory *)

      simrel_init_mem {F V}:
        Monotonic
          (Genv.init_mem (F:=F) (V:=V))
          (simrel_program_rel R ++>
           option_le (rexists w, match_mem R w));

      (** Properties for memory operations. *)

      simrel_alloc p:
        Monotonic
          Mem.alloc
          (match_mem R p ++> - ==> - ==>
           incr p (match_mem R p * match_block_sameofs R p));

      simrel_free p:
        Monotonic
          Mem.free
          (match_mem R p ++> rel_curry (rel_curry (match_ptrrange R p ==>
           option_le (incr p (match_mem R p)))));

      simrel_load p:
        Monotonic
          Mem.load
          (- ==> match_mem R p ++> rel_curry (match_ptr R p ++>
           option_le (match_val R p)));

      simrel_store p:
        Monotonic
          Mem.store
          (- ==> match_mem R p ++> rel_curry (match_ptr R p ++>
           match_val R p ++> option_le (incr p (match_mem R p))));

      simrel_loadbytes p:
        Monotonic
          Mem.loadbytes
          (match_mem R p ++> rel_curry (match_ptr R p ++> - ==>
           option_le (list_rel (match_memval R p))));

      simrel_storebytes p:
        Monotonic
          Mem.storebytes
          (match_mem R p ++>
           rel_curry (match_ptr R p ++> list_rel (match_memval R p) ++>
           option_le (incr p (match_mem R p))));

      simrel_perm p:
        Monotonic
          Mem.perm
          (match_mem R p ++> rel_curry (match_ptr R p ++> - ==> - ==> impl));

      simrel_valid_block p:
        Monotonic
          Mem.valid_block
          (match_mem R p ++> match_block R p ++> iff);

      (* similar to Mem.different_pointers_inject. Necessary for
         comparing valid pointers of different memory blocks that inject
         into the same block. *)
      simrel_different_pointers_inject
        p m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2:
        match_mem R p m m' ->
        b1 <> b2 ->
        Mem.valid_pointer m b1 (Ptrofs.unsigned ofs1) = true ->
        Mem.valid_pointer m b2 (Ptrofs.unsigned ofs2) = true ->
        simrel_meminj R p b1 = Some (b1', delta1) ->
        simrel_meminj R p b2 = Some (b2', delta2) ->
        b1' <> b2' \/
        Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <>
        Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2));

      (* similar to Mem.weak_valid_pointer_inject_val, but cannot be deduced
         from Mem.address_inject. Needed for Val.cmpu* *)
      simrel_weak_valid_pointer_inject_val p m1 m2 b1 ofs1 b2 ofs2:
        match_mem R p m1 m2 ->
        Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
        match_ptrbits R p (b1, ofs1) (b2, ofs2) ->
        Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned ofs2) = true;

      (** When comparing two weakly valid pointers of the same block
       using Val.cmpu, we need to compare their offsets, and so
       comparing the injected offsets must have the same result. To
       this end, it is necessary to show that all weakly valid
       pointers be shifted by the same mathematical (not machine)
       integer amount. However, contrary to the situation with
       Mem.address_inject for valid pointers, here for weakly valid
       pointers we do not know whether this amount is delta. The best
       we know, thanks to Mem.weak_valid_pointer_inject_no_overflow,
       is that Ptrofs.unsigned (Ptrofs.repr delta) works, but proving
       composition would be much harder than for the following
       weak version:
      *)

      simrel_weak_valid_pointer_address_inject_weak p m1 m2 b1 b2 delta:
        match_mem R p m1 m2 ->
        simrel_meminj R p b1 = Some (b2, delta) ->
        exists delta',
          forall ofs1,
            Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
            Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) =
            (Ptrofs.unsigned ofs1 + delta')%Z;

      (* similar to Mem.address_inject for memory injections.
         Needed at least by Clight assign_of (By_copy) and memcpy,
         but I guess at many other places. *)
      simrel_address_inject p m1 m2 b1 ofs1 b2 delta pe:
        match_mem R p m1 m2 ->
        Mem.perm m1 b1 (Ptrofs.unsigned ofs1) Cur pe ->
        simrel_meminj R p b1 = Some (b2, delta) ->
        Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) =
        (Ptrofs.unsigned ofs1 + delta)%Z;

      (* similar to Mem.aligned_area_inject for memory injections.
         Needed by Clight assign_of (By_copy) and memcpy. *)
      simrel_aligned_area_inject p m m' b ofs al sz b' delta:
        match_mem R p m m' ->
        (al = 1 \/ al = 2 \/ al = 4 \/ al = 8) ->
        sz > 0 ->
        (al | sz) ->
        Mem.range_perm m b ofs (ofs + sz) Cur Nonempty ->
        (al | ofs) ->
        simrel_meminj R p b = Some (b', delta) ->
        (al | ofs + delta);

      (* similar to Mem.disjoint_or_equal_inject for memory injections.
         Needed by Clight assign_of (By_copy) and memcpy. *)
      simrel_disjoint_or_equal_inject
        p m m' b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 sz:
        match_mem R p m m' ->
        simrel_meminj R p b1 = Some (b1', delta1) ->
        simrel_meminj R p b2 = Some (b2', delta2) ->
        Mem.range_perm m b1 ofs1
                       (ofs1 + sz) Max Nonempty ->
        Mem.range_perm m b2 ofs2
                       (ofs2 + sz) Max Nonempty ->
        sz > 0 ->
        b1 <> b2 \/
        ofs1 = ofs2 \/
        ofs1 + sz <= ofs2 \/ ofs2 + sz <= ofs1 ->
        b1' <> b2' \/
        (ofs1 + delta1 = ofs2 + delta2)%Z \/
        ofs1 + delta1 + sz <= ofs2 + delta2 \/
        ofs2 + delta2 + sz <= ofs1 + delta1
    }.

  Global Existing Instances simrel_acc_preorder.
  Global Existing Instances simrel_acc_undef_matches_pointer.
  Global Existing Instances simrel_acc_meminj.
  Global Existing Instances simrel_alloc.
  Local  Existing Instances simrel_free. (* strengthened version below *)
  Global Existing Instances simrel_load.
  Global Existing Instances simrel_store.
  Global Existing Instances simrel_loadbytes.
  Global Existing Instances simrel_storebytes.
  Global Existing Instances simrel_perm.
  Global Existing Instances simrel_valid_block.

  (* NB: Those need to be redeclared outside of the section. *)
  Global Instance: Params (@simrel_undef_matches_block) 2.
  Global Instance: Params (@simrel_meminj) 2.

  Global Instance: Params (@Genv.init_mem) 1.
  Global Instance: Params (@Mem.empty) 0.
  Global Instance: Params (@Mem.alloc) 3.
  Global Instance: Params (@Mem.free) 4.
  Global Instance: Params (@Mem.load) 4.
  Global Instance: Params (@Mem.store) 5.
  Global Instance: Params (@Mem.loadbytes) 4.
  Global Instance: Params (@Mem.storebytes) 4.
  Global Instance: Params (@Mem.loadv) 3.
  Global Instance: Params (@Mem.storev) 4.
  Global Instance: Params (@Mem.perm) 5.
  Global Instance: Params (@Mem.valid_block) 2.

  (** ** Packaging them up *)

  (** Though it is convenient to be able to define a simulation
    relation's operations and proofs separately, in most other contexts
    it is simpler to have a single object which bundles them together.

    Because simrel_ops is a coercion, a [simrel] can be used with
    [match_val], [match_block], etc. One thing to keep in mind is that
    if a parameter of your definition is only used in conjunction with
    one of these, its type will be inferred as [simrel_components],
    not [simrel].
   *)

  Record simrel :=
    {
      simrel_ops :> simrel_components;
      simrel_prf: SimulationRelation simrel_ops
    }.

  Global Existing Instance simrel_prf.

  (** ** Properties of derived relations *)

  Context `{HR: SimulationRelation}.

  (** *** Compatibility with the accessibility relation *)

  (* NB: Need to redeclare outside of the section *)
  Global Instance: Params (@match_ptr) 3.
  Global Instance: Params (@match_ptrbits) 3.
  Global Instance: Params (@match_ptrrange) 3.
  Global Instance: Params (@match_block) 3.
  Global Instance: Params (@match_block_sameofs) 3.
  Global Instance: Params (@match_val) 3.
  Global Instance: Params (@match_memval) 3.

  Global Instance match_ptr_acc:
    Monotonic (match_ptr R) ((≤) ++> subrel).
  Proof.
    intros p1 p2 Hp ptr1 ptr2 Hptr.
    destruct Hptr as [b1 ofs1 b2 delta Hb].
    transport Hb; subst.
    constructor; eauto.
  Qed.

  Global Instance match_ptrbits_acc:
    Monotonic (match_ptrbits R) ((≤) ++> subrel).
  Proof.
    intros p1 p2 Hp ptr1 ptr2 Hptr.
    destruct Hptr as [b1 ofs1 b2 delta Hb].
    transport Hb; subst.
    constructor; eauto.
  Qed.

  Global Instance match_ptrrange_acc:
    Monotonic (match_ptrrange R) ((≤) ++> subrel).
  Proof.
    intros p1 p2 Hp ptr1 ptr2 Hptr.
    destruct Hptr as [b1 ofs1 b2 ofs2 sz Hb].
    constructor; eauto.
    revert Hb.
    apply match_ptr_acc.
    assumption.
  Qed.

  Global Instance match_block_acc:
    Monotonic (match_block R) ((≤) ++> subrel).
  Proof.
    intros p1 p2 Hp b1 b2 [delta Hb].
    transport Hb; subst.
    eexists; eauto.
  Qed.

  Global Instance match_block_sameofs_acc:
    Monotonic (match_block_sameofs R) ((≤) ++> subrel).
  Proof.
    intros p1 p2 Hp b1 b2 Hb.
    transport Hb; subst.
    eauto.
  Qed.

  Global Instance match_val_acc:
    Monotonic (match_val R) ((≤) ++> subrel).
  Proof.
    intros p p' Hp x y Hxy.
    destruct Hxy; constructor; eauto.
    - rauto.
    - revert H; rauto.
  Qed.

  Global Instance match_memval_acc:
    Monotonic (match_memval R) ((≤) ++> subrel).
  Proof.
    intros p p' Hp x y Hxy.
    destruct Hxy; constructor; eauto.
    - rauto.
    - revert H0; rauto.
  Qed.

  (** *** Functionality *)

  Lemma match_ptr_functional p ptr ptr1 ptr2:
    match_ptr R p ptr ptr1 ->
    match_ptr R p ptr ptr2 ->
    ptr1 = ptr2.
  Proof.
    intros [b ofs b1 delta1 Hb1] Hb2'.
    inversion Hb2' as [xb xofs b2 delta2 Hb2]; clear Hb2'; subst.
    congruence.
  Qed.

  Lemma match_ptrbits_functional p ptr ptr1 ptr2:
    match_ptrbits R p ptr ptr1 ->
    match_ptrbits R p ptr ptr2 ->
    ptr1 = ptr2.
  Proof.
    intros [b ofs b1 delta1 Hb1] Hb2'.
    inversion Hb2' as [xb xofs b2 delta2 Hb2]; clear Hb2'; subst.
    congruence.
  Qed.

  Lemma match_ptrrange_functional p ptr ptr1 ptr2:
    match_ptrrange R p ptr ptr1 ->
    match_ptrrange R p ptr ptr2 ->
    ptr1 = ptr2.
  Proof.
    intros Hptr1 Hptr2.
    destruct Hptr1 as [b ofs b1 ofs1 sz1 H1].
    inversion Hptr2 as [xb xofs b2 ofs2 sz2]; clear Hptr2; subst.
    pose proof (match_ptr_functional p (b, ofs) (b1, ofs1) (b2, ofs2) H1 H).
    assert (sz1 = sz2).
    {
      eapply Z.add_reg_l; eauto.
    }
    congruence.
  Qed.

  Lemma match_block_functional p b b1 b2:
    match_block R p b b1 ->
    match_block R p b b2 ->
    b1 = b2.
  Proof.
    intros [d1 Hb1] [d2 Hb2].
    congruence.
  Qed.

  Lemma match_block_sameofs_functional p b b1 b2:
    match_block_sameofs R p b b1 ->
    match_block_sameofs R p b b2 ->
    b1 = b2.
  Proof.
    unfold match_block_sameofs.
    congruence.
  Qed.

  (** *** Shift-invariance *)

  Lemma match_ptr_shift p b1 ofs1 b2 ofs2 delta:
    match_ptr R p (b1, ofs1) (b2, ofs2) ->
    match_ptr R p (b1, ofs1 + delta)%Z (b2, ofs2 + delta)%Z.
  Proof.
    inversion 1; subst.
    rewrite <- Z.add_assoc.
    rewrite (Z.add_comm delta0 delta).
    rewrite Z.add_assoc.
    constructor; eauto.
  Qed.

  Lemma match_ptrbits_shift p b1 ofs1 b2 ofs2 delta:
    match_ptrbits R p (b1, ofs1) (b2, ofs2) ->
    match_ptrbits R p (b1, Ptrofs.add ofs1 delta) (b2, Ptrofs.add ofs2 delta).
  Proof.
    inversion 1; subst.
    rewrite Ptrofs.add_assoc.
    rewrite (Ptrofs.add_commut (Ptrofs.repr _)).
    rewrite <- Ptrofs.add_assoc.
    constructor; eauto.
  Qed.

  Lemma match_ptrrange_shift p b1 ofs1 sz1 b2 ofs2 sz2 delta:
    match_ptrrange R p (b1, ofs1, sz1) (b2, ofs2, sz2) ->
    match_ptrrange R p (b1, ofs1 + delta, sz1)%Z (b2, ofs2 + delta, sz2)%Z.
  Proof.
    inversion 1; subst.
    replace (ofs1 + sz)%Z with ((ofs1 + delta) + (sz - delta))%Z by omega.
    replace (ofs2 + sz)%Z with ((ofs2 + delta) + (sz - delta))%Z by omega.
    constructor.
    eapply match_ptr_shift; eauto.
  Qed.

  (** *** Relationships between [match_foo] relations *)

  (** We call each lemma [match_foo_bar] that establishes [match_bar]
    from a [match_foo] premise. When this can be done in several ways,
    we add a suffix to disambiguate. *)

  Lemma add_repr ofs1 delta:
    Ptrofs.repr (ofs1 + delta) =
    Ptrofs.add (Ptrofs.repr ofs1) (Ptrofs.repr delta).
  Proof.
      rewrite Ptrofs.add_unsigned.
      auto using Ptrofs.eqm_samerepr,
      Ptrofs.eqm_add, Ptrofs.eqm_unsigned_repr.
  Qed.

  Lemma match_ptr_ptrbits_repr p b1 ofs1 b2 ofs2:
    match_ptr R p (b1, ofs1) (b2, ofs2) ->
    match_ptrbits R p (b1, Ptrofs.repr ofs1) (b2, Ptrofs.repr ofs2).
  Proof.
    inversion 1; subst.
    rewrite add_repr.
    constructor.
    assumption.
  Qed.

  Lemma match_ptr_ptrbits_unsigned p b1 ofs1 b2 ofs2:
    match_ptr R p (b1, Ptrofs.unsigned ofs1) (b2, Ptrofs.unsigned ofs2) ->
    match_ptrbits R p (b1, ofs1) (b2, ofs2).
  Proof.
    intros H.
    rewrite <- (Ptrofs.repr_unsigned ofs1), <- (Ptrofs.repr_unsigned ofs2).
    apply match_ptr_ptrbits_repr; eauto.
  Qed.

  Lemma match_ptr_ptrrange p b1 lo1 hi1 b2 lo2 hi2:
    match_ptr R p (b1, lo1) (b2, lo2) ->
    hi1 - lo1 = hi2 - lo2 ->
    match_ptrrange R p (b1, lo1, hi1) (b2, lo2, hi2).
  Proof.
    intros Hlo Hhi.
    replace hi1 with (lo1 + (hi1 - lo1))%Z by omega.
    replace hi2 with (lo2 + (hi1 - lo1))%Z by omega.
    constructor; eauto.
  Qed.

  Lemma match_ptr_block p b1 ofs1 b2 ofs2:
    match_ptr R p (b1, ofs1) (b2, ofs2) ->
    match_block R p b1 b2.
  Proof.
    inversion 1.
    red.
    eauto.
  Qed.

  Lemma match_ptr_block_sameofs p b1 b2 ofs:
    match_ptr R p (b1, ofs) (b2, ofs) ->
    match_block_sameofs R p b1 b2.
  Proof.
    inversion 1.
    assert (delta = 0) by omega.
    red.
    congruence.
  Qed.

  Lemma match_ptrbits_ptr p m1 m2 b1 o1 b2 o2 pe:
    match_mem R p m1 m2 ->
    match_ptrbits R p (b1, o1) (b2, o2) ->
    Mem.perm m1 b1 (Ptrofs.unsigned o1) Cur pe ->
    match_ptr R p (b1, Ptrofs.unsigned o1) (b2, Ptrofs.unsigned o2).
  Proof.
    intros H H0 H1.
    inversion H0; subst.
    erewrite simrel_address_inject; eauto.
    constructor.
    assumption.
  Qed.

  Lemma match_ptrbits_block p b1 ofs1 b2 ofs2:
    match_ptrbits R p (b1, ofs1) (b2, ofs2) ->
    match_block R p b1 b2.
  Proof.
    inversion 1.
    red.
    eauto.
  Qed.

  Lemma match_ptrrange_ptr p ptr1 hi1 ptr2 hi2:
    match_ptrrange R p (ptr1, hi1) (ptr2, hi2) ->
    match_ptr R p ptr1 ptr2.
  Proof.
    inversion 1.
    assumption.
  Qed.

  Lemma match_block_ptr p b1 b2 ofs1:
    match_block R p b1 b2 ->
    exists ofs2, match_ptr R p (b1, ofs1) (b2, ofs2).
  Proof.
    intros [delta H].
    exists (ofs1 + delta)%Z.
    constructor; eauto.
  Qed.

  Lemma match_block_ptrbits p b1 b2 ofs1:
    match_block R p b1 b2 ->
    exists ofs2, match_ptrbits R p (b1, ofs1) (b2, ofs2).
  Proof.
    intros [delta H].
    exists (Ptrofs.add ofs1 (Ptrofs.repr delta)).
    constructor; eauto.
  Qed.

  Lemma match_block_ptrrange p b1 b2 lo1 hi1:
    match_block R p b1 b2 ->
    exists lo2 hi2, match_ptrrange R p (b1, lo1, hi1) (b2, lo2, hi2).
  Proof.
    intros [delta H].
    exists (lo1 + delta)%Z, ((lo1 + delta) + (hi1 - lo1))%Z.
    pattern hi1 at 1.
    replace hi1 with (lo1 + (hi1 - lo1))%Z by omega.
    constructor.
    constructor.
    assumption.
  Qed.

  Lemma match_block_sameofs_ptr p b1 ofs1 b2 ofs2:
    match_block_sameofs R p b1 b2 ->
    ofs1 = ofs2 ->
    match_ptr R p (b1, ofs1) (b2, ofs2).
  Proof.
    intros Hb Hofs.
    red in Hb.
    destruct Hofs.
    pattern ofs1 at 2.
    replace ofs1 with (ofs1 + 0)%Z by omega.
    constructor; eauto.
  Qed.

  Lemma match_block_sameofs_ptrbits p b1 ofs1 b2 ofs2:
    match_block_sameofs R p b1 b2 ->
    ofs1 = ofs2 ->
    match_ptrbits R p (b1, ofs1) (b2, ofs2).
  Proof.
    intros Hb Hofs.
    red in Hb.
    destruct Hofs.
    pattern ofs1 at 2.
    replace ofs1 with (Ptrofs.add ofs1 (Ptrofs.repr 0%Z)).
    - constructor; eauto.
    - change (Ptrofs.repr 0) with Ptrofs.zero.
      apply Ptrofs.add_zero.
  Qed.

  Lemma match_block_sameofs_ptrrange p b1 lo1 hi1 b2 lo2 hi2:
    match_block_sameofs R p b1 b2 ->
    lo1 = lo2 ->
    hi1 = hi2 ->
    match_ptrrange R p (b1, lo1, hi1) (b2, lo2, hi2).
  Proof.
    intros Hb Hlo Hhi.
    red in Hb.
    subst.
    eapply match_ptr_ptrrange; eauto.
    eapply match_block_sameofs_ptr; eauto.
  Qed.

  Global Instance match_block_sameofs_block p:
    Related (match_block_sameofs R p) (match_block R p) subrel.
  Proof.
    clear.
    firstorder.
  Qed.

  (** *** Global blocks *)

  Lemma match_global_ptr p b ofs:
    block_is_global b ->
    Monotonic (b, ofs) (match_ptr R p).
  Proof.
    intros Hb.
    eapply match_block_sameofs_ptr; eauto.
    eapply match_global_block_sameofs; eauto.
  Qed.

  Lemma match_global_ptrbits p b ofs:
    block_is_global b ->
    Monotonic (b, ofs) (match_ptrbits R p).
  Proof.
    intros Hb.
    eapply match_block_sameofs_ptrbits; eauto.
    eapply match_global_block_sameofs; eauto.
  Qed.

  Lemma match_global_ptrrange p b lo hi:
    block_is_global b ->
    Monotonic (b, lo, hi) (match_ptrrange R p).
  Proof.
    intros Hb.
    eapply match_block_sameofs_ptrrange; eauto.
    eapply match_global_block_sameofs; eauto.
  Qed.

  Lemma match_global_block p b:
    block_is_global b ->
    Monotonic b (match_block R p).
  Proof.
    intros Hb.
    eapply match_block_sameofs_block.
    eapply match_global_block_sameofs; eauto.
  Qed.

  (** *** Miscellaneous *)

  Lemma match_val_weaken_to_undef p v1 v2:
    simrel_undef_matches_values R ->
    match_val R p v1 v2 ->
    match_val R p Vundef v2.
  Proof.
    intros HRundef Hv.
    destruct Hv; try rauto.
    constructor.
    eapply simrel_undef_matches_values_also_block; eauto.
  Qed.

  (** ** Properties of derived memory operations *)

  Global Instance simrel_loadv p:
    Monotonic
      Mem.loadv
      (- ==> match_mem R p ++> match_val R p ++> option_le (match_val R p)).
  Proof.
    repeat red.
    intros a x y H x0 y0 H0.
    inversion H0; subst; simpl; try now constructor.
    destruct (Mem.load a x _ (Ptrofs.unsigned _)) eqn:LOAD; try now constructor.
    rewrite <- LOAD.
    repeat rstep.
    eapply match_ptrbits_ptr; eauto.
    eapply Mem.load_valid_access; eauto.
    generalize (size_chunk_pos a); omega.
  Qed.

  Global Instance simrel_loadv_params:
    Params (@Mem.loadv) 3.

  Global Instance simrel_storev p:
    Monotonic
      Mem.storev
      (- ==> match_mem R p ++> match_val R p ++> match_val R p ++>
       option_le (incr p (match_mem R p))).
  Proof.
    intros a x y H x0 y0 H0 x1 y1 H1.
    destruct (Mem.storev a x _ _) eqn:STORE; [ | solve_monotonic ].
    rewrite <- STORE.
    inversion H0; subst; simpl; try rauto.
    simpl in * |- *.
    repeat rstep.
    eapply match_ptrbits_ptr; eauto.
    eapply Mem.store_valid_access_3; eauto.
    generalize (size_chunk_pos a); omega.
  Qed.

  Global Instance simrel_storev_params:
    Params (@Mem.storev) 4.

  (** XXX: Use a separate SimGlobalenvs.v ? *)
  Global Instance genv_find_symbol_match {F V Rf} p:
    Monotonic
      (Globalenvs.Genv.find_symbol (F:=F) (V:=V))
      (genv_le Rf ++> - ==> option_rel (match_block_sameofs R p)).
  Proof.
    intros ge1 ge2 Hge i.
    rewrite !stencil_matches_symbols by eauto.
    destruct (find_symbol i) eqn:Hi.
    - constructor.
      eapply match_global_block_sameofs.
      eapply find_symbol_block_is_global.
      eassumption.
    - constructor.
  Qed.

  Global Instance genv_find_symbol_match_params:
    Params (@Globalenvs.Genv.find_symbol) 2.

  (** Maybe it's possible to prove [simrel_storebytes] from [simrel_store]
    as well. But if it is, it's tricky. *)

  Global Instance simrel_free_list p:
    Monotonic
      Mem.free_list
      (match_mem R p ++> list_rel (match_ptrrange R p) ++>
       option_le (incr p (match_mem R p))).
  Proof.
    intros m1 m2 Hm l1 l2 Hl.
    revert p l2 Hl m1 m2 Hm.
    induction l1; inversion 1; subst; simpl; intros.
    - rauto.
    - rstep; rstep.
      rstep; rstep.
      + rauto.
      + split_hyp H4. (* XXX: need to update split_hyps to include rel_incr *)
        (* XXX: for whatever reason Coq needs to be reminded of this ?! *)
        Existing Instance rel_incr_subrel.
        exploit IHl1; [ | rauto | ]; try rauto.
  Qed.

  Global Instance simrel_free_list_params:
    Params (@Mem.free_list) 2.

  Global Instance mem_valid_pointer_match p:
    Monotonic
      Mem.valid_pointer
      (match_mem R p ++> rel_curry (match_ptr R p ++> Bool.leb)).
  Proof.
    intros m1 m2 Hm [b1 ofs1] [b2 ofs2] Hp.
    simpl.
    destruct (Mem.valid_pointer m1 b1 ofs1) eqn:Hp1; simpl; eauto.
    revert Hp1.
    rewrite !Mem.valid_pointer_nonempty_perm.
    solve_monotonic.
  Qed.

  Global Instance mem_valid_pointer_match_params:
    Params (@Mem.valid_pointer) 3.

  Global Instance mem_weak_valid_pointer_match p:
    Monotonic
      Mem.weak_valid_pointer
      (match_mem R p ++> rel_curry (match_ptr R p ++> Bool.leb)).
  Proof.
    intros m1 m2 Hm [b1 ofs1] [b2 ofs2] Hp.
    simpl.
    unfold Mem.weak_valid_pointer.
    repeat rstep.
    apply match_ptr_shift.
    assumption.
  Qed.

  Global Instance mem_weak_valid_pointer_match_params:
    Params (@Mem.weak_valid_pointer) 3.

  (** ** Strengthened properties for memory operations *)

  Definition ptrrange_perm `{Mem.MemoryModelOps} m k p: relation _ :=
    lsat (fun r => match r with (b, lo, hi) => Mem.range_perm m b lo hi k p end).

  Global Instance simrel_free_perm p:
    Monotonic
      Mem.free
      (forallr m1 m2 : match_mem R p,
         % % rel_impl (ptrrange_perm m1 Cur Freeable) (match_ptrrange R p) ==>
         option_le (incr p (match_mem R p))).
  Proof.
    rstep.
    repeat rstep.
    destruct x as [[b1 lo1] hi1], y as [[b2 lo2] hi2]; simpl.
    destruct (Mem.free v1 b1 lo1 hi1) eqn:Hfree; repeat rstep.
    assert (ptrrange_perm v1 Cur Freeable (b1, lo1, hi1) (b2, lo2, hi2)).
    {
      eapply Mem.free_range_perm.
      eassumption.
    }
    rewrite <- Hfree.
    rauto.
  Qed.

  (** When pointers are extracted from Compcert [val]ues, they use
    machine integers and we know related values contain pointers that
    are related by [match_ptrbits]. Often we then convert this machine
    pointer with offset [ofs] into an mathematical pointer with offset
    [Ptrofs.unsigned ofs]. This is made explicit for our block-offset
    pair pointers using the following function. *)

  Definition ptrofbits (p: block * ptrofs) :=
    let '(b, ofs) := p in (b, Ptrofs.unsigned ofs).

  (** Unfortunately we can't establish that the results of this
    process are related by [match_ptr] without proving the side
    conditions of [match_ptrbits_ptr]. However if the side-conditions
    can't be proved directly from the context, we can use the relation
    [match_ptrbits !! ptrofbits] to remember that they were
    constructed in this way instead.

    For many memory operations this is enough, because the success of
    whichever memory operation we will use the pointer with will be
    sufficient to prove the side-conditions for [match_ptrbits_ptr]. *)

  Require Import BoolRel.

  Global Instance match_ptrofbits_rintro p b1 ofs1 b2 ofs2:
    RIntro
      (match_ptrbits R p (b1, ofs1) (b2, ofs2))
      ((match_ptrbits R p) !! ptrofbits)
      (b1, Ptrofs.unsigned ofs1)
      (b2, Ptrofs.unsigned ofs2).
  Proof.
    intros H.
    change (b1, Ptrofs.unsigned ofs1) with (ptrofbits (b1, ofs1)).
    change (b2, Ptrofs.unsigned ofs2) with (ptrofbits (b2, ofs2)).
    constructor; eauto.
  Qed.

  Global Instance valid_pointer_match p:
    Monotonic
      Mem.valid_pointer
      (match_mem R p ++> % (match_ptrbits R p) !! ptrofbits ++>
       flex_leb (simrel_undef_matches_values R)).
  Proof.
    intros m1 m2 Hm _ _ [[b1 ofs1] [b2 ofs2] H].
    simpl.
    destruct (Mem.valid_pointer m1 _ _) eqn:H1.
    - assert (match_ptr R p (b1, Ptrofs.unsigned ofs1) (b2, Ptrofs.unsigned ofs2)).
      {
        eapply match_ptrbits_ptr; repeat rstep.
        eapply Mem.valid_pointer_nonempty_perm; eauto.
      }
      transport H1.
      rewrite H1.
      constructor.
    - destruct (Mem.valid_pointer m2 _ _) eqn:H2; repeat rstep.
      constructor.
      eapply simrel_undef_matches_block_also_values.
      eapply simrel_undef_matches_block_invalid; eauto.
  Qed.

  Global Instance weak_valid_pointer_match p:
    Monotonic
      Mem.weak_valid_pointer
      (match_mem R p ++> % (match_ptrbits R p) !! ptrofbits ++>
       flex_leb (simrel_undef_matches_values R)).
  Proof.
    intros m1 m2 Hm _ _ [[b1 ofs1] [b2 ofs2] Hptr].
    change ((flex_leb (simrel_undef_matches_values R))
              (Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs1))
              (Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned ofs2))).
    destruct (Mem.weak_valid_pointer m1 _ _) eqn:Hwvp1.
    - erewrite (simrel_weak_valid_pointer_inject_val p); eauto.
      constructor.
    - destruct (Mem.weak_valid_pointer m2 _ _) eqn:Hwbp2.
      + constructor.
        eapply simrel_undef_matches_block_also_values.
        eapply simrel_undef_matches_block_invalid_weak; eauto.
      + constructor.
  Qed.

  Global Instance valid_pointer_weaken_match p:
    Related
      Mem.valid_pointer
      Mem.weak_valid_pointer
      (match_mem R p ++> % (match_ptrbits R p) !! ptrofbits ++> leb).
  Proof.
    intros m1 m2 Hm _ _ [[b1 ofs1] [b2 ofs2] H].
    simpl.
    transitivity (Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs1)).
    - unfold Mem.weak_valid_pointer.
      apply left_upper_bound.
    - rauto.
  Qed.
End DEFINITION.

(** We make the memory models involved with a given simulation
  relation kit explicit. *)

Global Arguments simrel_components {_} D1 D2.
Global Arguments simrel {_} D1 D2.

(** We need to make sure those are out of the section so that no
  arguments are generalized at section exit. *)

Global Instance: Params (@simrel_undef_matches_block) 2.
Global Instance: Params (@simrel_meminj) 2.
Global Instance: Params (@match_mem) 3.
Global Instance: Params (@match_ptr) 3.
Global Instance: Params (@match_ptrbits) 3.
Global Instance: Params (@match_ptrrange) 3.
Global Instance: Params (@match_block) 3.
Global Instance: Params (@match_block_sameofs) 3.
Global Instance: Params (@match_val) 3.
Global Instance: Params (@match_memval) 3.

(** Make sure we can use the relationship between
  [simrel_undef_matches_values] and [simrel_undef_matches_block]
  during typeclass instance resolution. *)

Hint Extern 2 (simrel_undef_matches_block ?R ?p ?b2) =>
  eapply simrel_undef_matches_values_also_block; eassumption
  : typeclass_instances.

Hint Extern 1 (simrel_undef_matches_values ?R) =>
  eapply simrel_undef_matches_block_also_values; eassumption
  : typeclass_instances.

(** Re-register the [simrel_option_le] notation outside of the section. *)

Global Notation simrel_option_le R :=
  (flex_option_le (simrel_undef_matches_values R)).

Global Notation simrel_leb R :=
  (flex_leb (simrel_undef_matches_values R)).

(** * Tactics *)

(** Here we define some tactics which may be useful when building up
  on our simulation relation tookits. *)

(* Inverse hypothese for some relations when the left-hand side has a
  specific form. For now, we use an ad-hoc tactic, but maybe we could
  find a way to strengthen the relators associated with [nil], [cons],
  [Vint], [Vptr], etc. to express the properties used here. *)

Ltac inverse_hyps :=
  repeat
    lazymatch goal with
      | H: list_rel ?R (?x :: ?xs) ?yl |- _ =>
        inversion H; clear H; subst
      | H: list_rel ?R nil ?yl |- _ =>
        inversion H; clear H; subst
      | H: match_val ?R ?p (Vint _) ?y |- _ =>
        inversion H; clear H; subst
      | H: match_val ?R ?p (Vlong _) ?y |- _ =>
        inversion H; clear H; subst
      | H: match_val ?R ?p (Vfloat _) ?y |- _ =>
        inversion H; clear H; subst
      | H: match_val ?R ?p (Vsingle _) ?y |- _ =>
        inversion H; clear H; subst
      | H: match_val ?R ?p (Vptr _ _) ?y |- _ =>
        inversion H; clear H; subst
    end.

(** Another common need is to solve a goal which consists in [set_rel]
  used in conjunction with an inductive type. The [deconstruct] tactic
  destructs a hypothesis [H], and for each generated subgoal passes
  the corresponding constructor to the continuation k. *)

Ltac head m :=
  lazymatch m with
    | ?x _ => head x
    | ?x => constr:(x)
  end.

Ltac deconstruct H k :=
  let HH := fresh in
  destruct H eqn:HH;
  lazymatch type of HH with
    | _ = ?cc =>
      let c := head cc in
      clear HH; k c
  end.

(** We can use that to build a systematic way to solve goals which
  related two elements of an inductive type with [set_rel]. Namely,
  destruct the hypothesis which states the left-hand side is in the
  set, then for each branch transport all of the premises and apply
  the same constructor again. *)

Ltac solve_set_rel :=
  lazymatch goal with
    | |- set_rel _ _ _ =>
      let H := fresh in
      let reconstruct c :=
        idtac "Using constructor" c;
        clear H;
        split_hyps;
        inverse_hyps;
        transport_hyps;
        try (eexists; split; [eapply c; eauto | repeat rstep]) in
      intros ? H;
      deconstruct H reconstruct
    | |- impl _ _ =>
      let H := fresh in
      let reconstruct c :=
        idtac "Using constructor" c;
        clear H;
        split_hyps;
        inverse_hyps;
        transport_hyps;
        try (eapply c; eauto) in
      intros H;
      deconstruct H reconstruct
    | |- _ =>
      intro; solve_set_rel
  end.

(** This can be useful when [rel_curry] is involved *)
Ltac eexpair :=
  lazymatch goal with
    | |- @ex (prod ?T1 ?T2) _ =>
      let xv := fresh in evar (xv: T1);
      let x := eval red in xv in clear xv;
      let yv := fresh in evar (yv: T2);
      let y := eval red in yv in clear yv;
      exists (x, y); simpl
  end.


Require Import Kami.AllNotations.
Require Import StdLibKami.RegArray.Ifc.

Section Impl.
  Context {ifcParams: Ifc.Params}.

  Local Notation Idx := (Bit (Nat.log2_up size)).

  Local Open Scope kami_expr.
  Local Open Scope kami_action.

  Local Definition names := map (fun i => name ++ "_" ++ natToHexStr i)%string (seq 0 size).

  Local Definition read ty (idx: ty Idx) : ActionT ty k :=
   GatherActions (map (fun '(i, reg) => Read val: k <- reg;
                      Ret (IF ($i == #idx)
                           then #val else $$(getDefaultConst k))) (tag names)) as vals;
   Ret (Kor vals).

  Local Definition write ty (writeRq: ty (WriteRq (Nat.log2_up size) k)): ActionT ty Void :=
    GatherActions (map (fun '(i, reg) => Read val: k <- reg;
                                         Write reg: k <- (IF $i == #writeRq @% "addr" then #writeRq @% "data" else #val);
                                         Retv) (tag names)) as _;
    Retv.

  Definition impl := {| regs := map (fun i => (i, existT RegInitValT (SyntaxKind k) match init with
                                                                                | None => None
                                                                                | Some x => Some (SyntaxConst x)
                                                                                end)) names;
                        regFiles := nil;
                        Ifc.read := read;
                        Ifc.write := write |}.
End Impl.