(* *********************************************************************)
(*                                                                     *)
(*              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: relational specification *)

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

(** ** Soundness of function environments. *)

(** A compile-time function environment is compatible with a whole
  program if the following condition holds. *)

Definition fenv_compat (p: program) (fenv: funenv) : Prop :=
  forall id f,
  fenv!id = Some f -> (prog_defmap p)!id = Some (Gfun (Internal f)).

Lemma funenv_program_compat:
  forall p, fenv_compat p (funenv_program p).
Proof.
  set (P := fun (dm: PTree.t (globdef fundef unit)) (fenv: funenv) =>
              forall id f,
              fenv!id = Some f -> dm!id = Some (Gfun (Internal f))).
  assert (REMOVE: forall dm fenv id g,
             P dm fenv ->
             P (PTree.set id g dm) (PTree.remove id fenv)).
  { unfold P; intros. rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id).
    discriminate.
    rewrite PTree.gso; auto.
  }
  assert (ADD: forall io dm fenv idg,
             P dm fenv ->
             P (PTree.set (fst idg) (snd idg) dm) (add_globdef io fenv idg)).
  { intros io dm fenv [id g]; simpl; intros.
    destruct g as [ [f|ef] | v]; auto.
    destruct (should_inline io id f); auto.
    red; intros. rewrite ! PTree.gsspec in *.
    destruct (peq id0 id); auto. inv H0; auto.
  }
  assert (REC: forall p l dm fenv,
            P dm fenv ->
            P (fold_left (fun x idg => PTree.set (fst idg) (snd idg) x) l dm)
              (fold_left (add_globdef p) l fenv)).
  { induction l; simpl; intros.
  - auto.
  - apply IHl. apply ADD; auto.
  }
  intros. apply REC. red; intros.  rewrite PTree.gempty in H; discriminate.
Qed.

Lemma fenv_compat_linkorder:
  forall cunit prog fenv,
  linkorder cunit prog -> fenv_compat cunit fenv -> fenv_compat prog fenv.
Proof.
  intros; red; intros. apply H0 in H1.
  destruct (prog_defmap_linkorder _ _ _ _ H H1) as (gd' & P & Q).
  inv Q. inv H3. auto.
Qed.

(** ** Properties of shifting *)

Lemma shiftpos_eq: forall x y, Zpos (shiftpos x y) = (Zpos x + Zpos y) - 1.
Proof.
  intros. unfold shiftpos. zify.  try rewrite Pos2Z.inj_sub. auto.
  zify. lia.
Qed.

Lemma shiftpos_inj:
  forall x y n, shiftpos x n = shiftpos y n -> x = y.
Proof.
  intros.
  assert (Zpos (shiftpos x n) = Zpos (shiftpos y n)) by congruence.
  rewrite ! shiftpos_eq in H0.
  assert (Z.pos x = Z.pos y) by lia.
  congruence.
Qed.

Lemma shiftpos_diff:
  forall x y n, x <> y -> shiftpos x n <> shiftpos y n.
Proof.
  intros; red; intros. elim H. eapply shiftpos_inj; eauto.
Qed.

Lemma shiftpos_above:
  forall x n, Ple n (shiftpos x n).
Proof.
  intros. unfold Ple; zify. rewrite shiftpos_eq. extlia.
Qed.

Lemma shiftpos_not_below:
  forall x n, Plt (shiftpos x n) n -> False.
Proof.
  intros. generalize (shiftpos_above x n). extlia.
Qed.

Lemma shiftpos_below:
  forall x n, Plt (shiftpos x n) (Pos.add x n).
Proof.
  intros. unfold Plt; zify. rewrite shiftpos_eq. lia.
Qed.

Lemma shiftpos_le:
  forall x y n, Ple x y -> Ple (shiftpos x n) (shiftpos y n).
Proof.
  intros. unfold Ple in *; zify. rewrite ! shiftpos_eq. lia.
Qed.

(** ** Working with the state monad *)

Remark bind_inversion:
  forall (A B: Type) (f: mon A) (g: A -> mon B)
         (y: B) (s1 s3: state) (i: sincr s1 s3),
  bind f g s1 = R y s3 i ->
  exists x, exists s2, exists i1, exists i2,
  f s1 = R x s2 i1 /\ g x s2 = R y s3 i2.
Proof.
  unfold bind; intros. destruct (f s1). exists x; exists s'; exists I.
  destruct (g x s'). inv H. exists I0; auto.
Qed.

Ltac monadInv1 H :=
  match type of H with
  | (R _ _ _ = R _ _ _) =>
      inversion H; clear H; try subst
  | (ret _ _ = R _ _ _) =>
      inversion H; clear H; try subst
  | (bind ?F ?G ?S = R ?X ?S' ?I) =>
      let x := fresh "x" in (
      let s := fresh "s" in (
      let i1 := fresh "INCR" in (
      let i2 := fresh "INCR" in (
      let EQ1 := fresh "EQ" in (
      let EQ2 := fresh "EQ" in (
      destruct (bind_inversion _ _ F G X S S' I H) as [x [s [i1 [i2 [EQ1 EQ2]]]]];
      clear H;
      try (monadInv1 EQ2)))))))
  end.

Ltac monadInv H :=
  match type of H with
  | (ret _ _ = R _ _ _) => monadInv1 H
  | (bind ?F ?G ?S = R ?X ?S' ?I) => monadInv1 H
  | (?F _ _ _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  end.

Fixpoint mlist_iter2 {A B: Type} (f: A -> B -> mon unit) (l: list (A*B)): mon unit :=
  match l with
  | nil => ret tt
  | (x,y) :: l' => do z <- f x y; mlist_iter2 f l'
  end.

Remark mlist_iter2_fold:
  forall (A B: Type) (f: A -> B -> mon unit) l s,
  exists i,
  mlist_iter2 f l s =
  R tt (fold_left (fun a p => match f (fst p) (snd p) a with R _ s2 _ => s2 end) l s) i.
Proof.
  induction l; simpl; intros.
  exists (sincr_refl s); auto.
  destruct a as [x y]. unfold bind. simpl. destruct (f x y s) as [xx s1 i1].
  destruct (IHl s1) as [i2 EQ]. rewrite EQ. econstructor; eauto.
Qed.

Lemma ptree_mfold_spec:
  forall (A: Type) (f: positive -> A -> mon unit) t s x s' i,
  ptree_mfold f t s = R x s' i ->
  exists i', mlist_iter2 f (PTree.elements t) s = R tt s' i'.
Proof.
  intros.
  destruct (mlist_iter2_fold _ _ f (PTree.elements t) s) as [i' EQ].
  unfold ptree_mfold in H. inv H. rewrite PTree.fold_spec.
  econstructor. eexact EQ.
Qed.

(** ** Relational specification of the translation of moves *)

Inductive tr_moves (c: code) : node -> list reg -> list reg -> node -> Prop :=
  | tr_moves_cons: forall pc1 src srcs dst dsts pc2 pc3,
      tr_moves c pc1 srcs dsts pc2 ->
      c!pc2 = Some(Iop Omove (src :: nil) dst pc3) ->
      tr_moves c pc1 (src :: srcs) (dst :: dsts) pc3
  | tr_moves_nil: forall srcs dsts pc,
      srcs = nil \/ dsts = nil ->
      tr_moves c pc srcs dsts pc.

Lemma add_moves_unchanged:
  forall srcs dsts pc2 s pc1 s' i pc,
  add_moves srcs dsts pc2 s = R pc1 s' i ->
  Plt pc s.(st_nextnode) \/ Ple s'.(st_nextnode) pc ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  induction srcs; simpl; intros.
  monadInv H. auto.
  destruct dsts; monadInv H. auto.
  transitivity (st_code s0)!pc. eapply IHsrcs; eauto. monadInv EQ; simpl. extlia.
  monadInv EQ; simpl. apply PTree.gso.
  inversion INCR0; simpl in *. extlia.
Qed.

Lemma add_moves_spec:
  forall srcs dsts pc2 s pc1 s' i c,
  add_moves srcs dsts pc2 s = R pc1 s' i ->
  (forall pc, Ple s.(st_nextnode) pc -> Plt pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) ->
  tr_moves c pc1 srcs dsts pc2.
Proof.
  induction srcs; simpl; intros.
  monadInv H. apply tr_moves_nil; auto.
  destruct dsts; monadInv H. apply tr_moves_nil; auto.
  apply tr_moves_cons with x. eapply IHsrcs; eauto.
  intros. inversion INCR. apply H0; extlia.
  monadInv EQ.
  rewrite H0. erewrite add_moves_unchanged; eauto.
  simpl. apply PTree.gss.
  simpl. extlia.
  extlia.
  inversion INCR; inversion INCR0; simpl in *; extlia.
Qed.

(** ** Relational specification of CFG expansion *)

Section INLINING_SPEC.

Variable fenv: funenv.

Definition context_below (ctx1 ctx2: context): Prop :=
  Ple (Pos.add ctx1.(dreg) ctx1.(mreg)) ctx2.(dreg).

Definition context_stack_call (ctx1 ctx2: context): Prop :=
  ctx1.(mstk) >= 0 /\ ctx1.(dstk) + ctx1.(mstk) <= ctx2.(dstk).

Definition context_stack_tailcall (ctx1: context) (f: function) (ctx2: context) : Prop :=
  ctx2.(dstk) = align ctx1.(dstk) (min_alignment f.(fn_stacksize)).

Section INLINING_BODY_SPEC.

Variable stacksize: Z.

Inductive tr_instr: context -> node -> instruction -> code -> Prop :=
  | tr_nop: forall ctx pc c s,
      c!(spc ctx pc) = Some (Inop (spc ctx s)) ->
      tr_instr ctx pc (Inop s) c
  | tr_op: forall ctx pc c op args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Iop op args res s) c
  | tr_load: forall ctx pc c chunk addr args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Iload chunk addr args res s) c
  | tr_store: forall ctx pc c chunk addr args src s,
      c!(spc ctx pc) = Some (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s)) ->
      tr_instr ctx pc (Istore chunk addr args src s) c
  | tr_call: forall ctx pc c sg ros args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Icall sg ros args res s) c
  | tr_call_inlined:forall ctx pc sg id args res s c f pc1 ctx',
      Ple res ctx.(mreg) ->
      fenv!id = Some f ->
      c!(spc ctx pc) = Some(Inop pc1) ->
      tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) ->
      tr_funbody ctx' f c ->
      ctx'.(retinfo) = Some(spc ctx s, sreg ctx res) ->
      context_below ctx ctx' ->
      context_stack_call ctx ctx' ->
      tr_instr ctx pc (Icall sg (inr _ id) args res s) c
  | tr_tailcall: forall ctx pc c sg ros args,
      c!(spc ctx pc) = Some (Itailcall sg (sros ctx ros) (sregs ctx args)) ->
      ctx.(retinfo) = None ->
      tr_instr ctx pc (Itailcall sg ros args) c
  | tr_tailcall_call: forall ctx pc c sg ros args res s,
      c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) res s) ->
      ctx.(retinfo) = Some(s, res) ->
      tr_instr ctx pc (Itailcall sg ros args) c
  | tr_tailcall_inlined: forall ctx pc sg id args c f pc1 ctx',
      fenv!id = Some f ->
      c!(spc ctx pc) = Some(Inop pc1) ->
      tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) ->
      tr_funbody ctx' f c ->
      ctx'.(retinfo) = ctx.(retinfo) ->
      context_below ctx ctx' ->
      context_stack_tailcall ctx f ctx' ->
      tr_instr ctx pc (Itailcall sg (inr _ id) args) c
  | tr_builtin: forall ctx pc c ef args res s,
      match res with BR r => Ple r ctx.(mreg) | _ => True end ->
      c!(spc ctx pc) = Some (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Ibuiltin ef args res s) c
  | tr_cond: forall ctx pc cond args s1 s2 c,
      c!(spc ctx pc) = Some (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2)) ->
      tr_instr ctx pc (Icond cond args s1 s2) c
  | tr_jumptable: forall ctx pc r tbl c,
      c!(spc ctx pc) = Some (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl)) ->
      tr_instr ctx pc (Ijumptable r tbl) c
  | tr_return: forall ctx pc or c,
      c!(spc ctx pc) = Some (Ireturn (option_map (sreg ctx) or)) ->
      ctx.(retinfo) = None ->
      tr_instr ctx pc (Ireturn or) c
  | tr_return_inlined: forall ctx pc or c rinfo,
      c!(spc ctx pc) = Some (inline_return ctx or rinfo) ->
      ctx.(retinfo) = Some rinfo ->
      tr_instr ctx pc (Ireturn or) c

with tr_funbody: context -> function -> code -> Prop :=
  | tr_funbody_intro: forall ctx f c,
      (forall r, In r f.(fn_params) -> Ple r ctx.(mreg)) ->
      (forall pc i, f.(fn_code)!pc = Some i -> tr_instr ctx pc i c) ->
      ctx.(mstk) = Z.max f.(fn_stacksize) 0 ->
      (min_alignment f.(fn_stacksize) | ctx.(dstk)) ->
      ctx.(dstk) >= 0 -> ctx.(dstk) + ctx.(mstk) <= stacksize ->
      tr_funbody ctx f c.

Definition fenv_agree (fe: funenv) : Prop :=
  forall id f, fe!id = Some f -> fenv!id = Some f.

Section EXPAND_INSTR.

Variable fe: funenv.
Hypothesis FE: fenv_agree fe.

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

Hypothesis rec_unchanged:
  forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i pc,
  rec fe' L ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.

Remark set_instr_other:
  forall pc instr s x s' i pc',
  set_instr pc instr s = R x s' i ->
  pc' <> pc ->
  s'.(st_code)!pc' = s.(st_code)!pc'.
Proof.
  intros. monadInv H; simpl. apply PTree.gso; auto.
Qed.

Remark set_instr_same:
  forall pc instr s x s' i c,
  set_instr pc instr s = R x s' i ->
  c!(pc) = s'.(st_code)!pc ->
  c!(pc) = Some instr.
Proof.
  intros. rewrite H0. monadInv H; simpl. apply PTree.gss.
Qed.

Lemma expand_instr_unchanged:
  forall ctx pc instr s x s' i pc',
  expand_instr fe rec ctx pc instr s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc' s.(st_nextnode) ->
  pc' <> spc ctx pc ->
  s'.(st_code)!pc' = s.(st_code)!pc'.
Proof.
  generalize set_instr_other; intros A.
  intros. unfold expand_instr in H; destruct instr; eauto.
(* call *)
  destruct (can_inline fe s1). eauto.
  monadInv H. unfold inline_function in EQ. monadInv EQ.
  transitivity (s2.(st_code)!pc'). eauto.
  transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto.
    left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. extlia.
  transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto.
    simpl. monadInv EQ; simpl. monadInv EQ1; simpl. extlia.
    simpl. monadInv EQ1; simpl. auto.
  monadInv EQ; simpl. monadInv EQ1; simpl. auto.
(* tailcall *)
  destruct (can_inline fe s1).
  destruct (retinfo ctx) as [[rpc rreg]|]; eauto.
  monadInv H. unfold inline_tail_function in EQ. monadInv EQ.
  transitivity (s2.(st_code)!pc'). eauto.
  transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto.
    left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. extlia.
  transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto.
    simpl. monadInv EQ; simpl. monadInv EQ1; simpl. extlia.
    simpl. monadInv EQ1; simpl. auto.
  monadInv EQ; simpl. monadInv EQ1; simpl. auto.
(* return *)
  destruct (retinfo ctx) as [[rpc rreg]|]; eauto.
Qed.

Lemma iter_expand_instr_unchanged:
  forall ctx pc l s x s' i,
  mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc s.(st_nextnode) ->
  ~In pc (List.map (spc ctx) (List.map (@fst _ _) l)) ->
  list_norepet (List.map (@fst _ _) l) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  induction l; simpl; intros.
  (* base case *)
  monadInv H. auto.
  (* inductive case *)
  destruct a as [pc1 instr1]; simpl in *.
  monadInv H. inv H3.
  transitivity ((st_code s0)!pc).
  eapply IHl; eauto. destruct INCR; extlia. destruct INCR; extlia.
  eapply expand_instr_unchanged; eauto.
Qed.

Lemma expand_cfg_rec_unchanged:
  forall ctx f s x s' i pc,
  expand_cfg_rec fe rec ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ.
  transitivity ((st_code s0)!pc).
  exploit ptree_mfold_spec; eauto. intros [INCR' ITER].
  eapply iter_expand_instr_unchanged; eauto.
    subst s0; auto.
    subst s0; simpl. extlia.
    red; intros. exploit list_in_map_inv; eauto. intros [pc1 [A B]].
    subst pc. unfold spc in H1. eapply shiftpos_not_below; eauto.
    apply PTree.elements_keys_norepet.
  subst s0; auto.
Qed.

Hypothesis rec_spec:
  forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i c,
  rec fe' L ctx f s = R x s' i ->
  fenv_agree fe' ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_reg_function f ->
  Ple (Pos.add ctx.(dreg) ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Z.max (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc, Ple ctx.(dpc) pc -> Plt pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) ->
  tr_funbody ctx f c.

Remark min_alignment_pos:
  forall sz, min_alignment sz > 0.
Proof.
  intros; unfold min_alignment.
  destruct (zle sz 1). lia. destruct (zle sz 2). lia. destruct (zle sz 4); lia.
Qed.

Ltac inv_incr :=
  match goal with
  | [ H: sincr _ _ |- _ ] => destruct H; inv_incr
  | _ => idtac
  end.

Lemma expand_instr_spec:
  forall ctx pc instr s x s' i c,
  expand_instr fe rec ctx pc instr s = R x s' i ->
  (forall r, instr_defs instr = Some r -> Ple r ctx.(mreg)) ->
  Plt (spc ctx pc) s.(st_nextnode) ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple s.(st_nextnode) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  c!(spc ctx pc) = s'.(st_code)!(spc ctx pc) ->
  tr_instr ctx pc instr c.
Proof.
  intros until c; intros EXP DEFS OPC OREG STK1 STK2 STK3 S1 S2.
  generalize set_instr_same; intros BASE.
  unfold expand_instr in EXP; destruct instr; simpl in DEFS;
  try (econstructor; eauto; fail).
(* call *)
  destruct (can_inline fe s1) as [|id f P Q].
  (* not inlined *)
  eapply tr_call; eauto.
  (* inlined *)
  subst s1.
  monadInv EXP. unfold inline_function in EQ; monadInv EQ.
  set (ctx' := callcontext ctx x1 x2 (max_reg_function f) (fn_stacksize f) n r).
  inversion EQ0; inversion EQ1; inversion EQ. inv_incr.
  apply tr_call_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto.
  eapply BASE; eauto.
  eapply add_moves_spec; eauto.
    intros. rewrite S1. eapply set_instr_other; eauto. unfold node; extlia.
    extlia. extlia.
  eapply rec_spec; eauto.
    red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto.
    simpl. subst s2; simpl in *; extlia.
    simpl. subst s3; simpl in *; extlia.
    simpl. extlia.
    simpl. apply align_divides. apply min_alignment_pos.
    assert (dstk ctx + mstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. lia.
    lia.
    intros. simpl in H. rewrite S1.
    transitivity (s1.(st_code)!pc0). eapply set_instr_other; eauto. unfold node in *; extlia.
    eapply add_moves_unchanged; eauto. unfold node in *; extlia. extlia.
  red; simpl. subst s2; simpl in *. extlia.
  red; simpl. split. auto. apply align_le. apply min_alignment_pos.
(* tailcall *)
  destruct (can_inline fe s1) as [|id f P Q].
  (* not inlined *)
  destruct (retinfo ctx) as [[rpc rreg] | ] eqn:?.
  (* turned into a call *)
  eapply tr_tailcall_call; eauto.
  (* preserved *)
  eapply tr_tailcall; eauto.
  (* inlined *)
  subst s1.
  monadInv EXP. unfold inline_function in EQ; monadInv EQ.
  set (ctx' := tailcontext ctx x1 x2 (max_reg_function f) (fn_stacksize f)) in *.
  inversion EQ0; inversion EQ1; inversion EQ. inv_incr.
  apply tr_tailcall_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto.
  eapply BASE; eauto.
  eapply add_moves_spec; eauto.
    intros. rewrite S1. eapply set_instr_other; eauto. unfold node; extlia. extlia. extlia.
  eapply rec_spec; eauto.
    red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto.
    simpl. subst s3; simpl in *. subst s2; simpl in *. extlia.
    simpl. subst s3; simpl in *; extlia.
    simpl. extlia.
    simpl. apply align_divides. apply min_alignment_pos.
    assert (dstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. lia.
    lia.
    intros. simpl in H. rewrite S1.
    transitivity (s1.(st_code))!pc0. eapply set_instr_other; eauto. unfold node in *; extlia.
    eapply add_moves_unchanged; eauto. unfold node in *; extlia. extlia.
  red; simpl.
subst s2; simpl in *; extlia.
  red; auto.
(* builtin *)
  eapply tr_builtin; eauto. destruct b; eauto.
(* return *)
  destruct (retinfo ctx) as [[rpc rreg] | ] eqn:?.
  (* inlined *)
  eapply tr_return_inlined; eauto.
  (* unchanged *)
  eapply tr_return; eauto.
Qed.

Lemma iter_expand_instr_spec:
  forall ctx l s x s' i c,
  mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i ->
  list_norepet (List.map (@fst _ _) l) ->
  (forall pc instr r, In (pc, instr) l -> instr_defs instr = Some r -> Ple r ctx.(mreg)) ->
  (forall pc instr, In (pc, instr) l -> Plt (spc ctx pc) s.(st_nextnode)) ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple s.(st_nextnode) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  (forall pc instr, In (pc, instr) l -> c!(spc ctx pc) = s'.(st_code)!(spc ctx pc)) ->
  forall pc instr, In (pc, instr) l -> tr_instr ctx pc instr c.
Proof.
  induction l; simpl; intros.
  (* base case *)
  contradiction.
  (* inductive case *)
  destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr.
  assert (A: Ple ctx.(dpc) s0.(st_nextnode)).
    assert (B: Plt (spc ctx pc) (st_nextnode s)) by eauto.
    unfold spc in B. generalize (shiftpos_above pc (dpc ctx)). extlia.
  destruct H9. inv H.
  (* same pc *)
  eapply expand_instr_spec; eauto.
  lia.
  intros.
    transitivity ((st_code s')!pc').
    apply H7. auto. extlia.
    eapply iter_expand_instr_unchanged; eauto.
    red; intros. rewrite list_map_compose in H9. exploit list_in_map_inv; eauto.
    intros [[pc0 instr0] [P Q]]. simpl in P.
    assert (Plt (spc ctx pc0) (st_nextnode s)) by eauto. extlia.
  transitivity ((st_code s')!(spc ctx pc)).
    eapply H8; eauto.
    eapply iter_expand_instr_unchanged; eauto.
    assert (Plt (spc ctx pc) (st_nextnode s)) by eauto. extlia.
    red; intros. rewrite list_map_compose in H. exploit list_in_map_inv; eauto.
    intros [[pc0 instr0] [P Q]]. simpl in P.
    assert (pc = pc0) by (eapply shiftpos_inj; eauto). subst pc0.
    elim H12. change pc with (fst (pc, instr0)). apply List.in_map; auto.
  (* older pc *)
  inv_incr. eapply IHl; eauto.
  intros. eapply Pos.lt_le_trans. eapply H2. right; eauto. extlia.
  intros; eapply Ple_trans; eauto.
  intros. apply H7; auto. extlia.
Qed.

Lemma expand_cfg_rec_spec:
  forall ctx f s x s' i c,
  expand_cfg_rec fe rec ctx f s = R x s' i ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_reg_function f ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Z.max (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple ctx.(dpc) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  tr_funbody ctx f c.
Proof.
  intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ.
  constructor.
  intros. rewrite H1. eapply max_reg_function_params; eauto.
  intros. exploit ptree_mfold_spec; eauto. intros [INCR' ITER].
  eapply iter_expand_instr_spec; eauto.
    apply PTree.elements_keys_norepet.
    intros. rewrite H1. eapply max_reg_function_def with (i := instr); eauto.
    eapply PTree.elements_complete; eauto.
  intros.
    assert (Ple pc0 (max_pc_function f)).
      eapply max_pc_function_sound. eapply PTree.elements_complete; eauto.
      eapply Pos.lt_le_trans. apply shiftpos_below. subst s0; simpl; extlia.
  subst s0; simpl; auto.
  intros. apply H8; auto. subst s0; simpl in H11; extlia.
  intros. apply H8. apply shiftpos_above.
  assert (Ple pc0 (max_pc_function f)).
    eapply max_pc_function_sound. eapply PTree.elements_complete; eauto.
  eapply Pos.lt_le_trans. apply shiftpos_below. inversion i; extlia.
  apply PTree.elements_correct; auto.
  auto. auto. auto.
  inversion INCR0. subst s0; simpl in STKSIZE; extlia.
Qed.

End EXPAND_INSTR.

Lemma expand_cfg_unchanged:
  forall fe ctx f s x s' i pc,
  expand_cfg fe ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv).
  apply well_founded_ltof.
  intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0.
  eapply expand_cfg_rec_unchanged; eauto. assumption.
Qed.

Lemma expand_cfg_spec:
  forall fe ctx f s x s' i c,
  expand_cfg fe ctx f s = R x s' i ->
  fenv_agree fe ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_reg_function f ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Z.max (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple ctx.(dpc) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  tr_funbody ctx f c.
Proof.
  intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv).
  apply well_founded_ltof.
  intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0.
  eapply expand_cfg_rec_spec; eauto.
  simpl. intros. eapply expand_cfg_unchanged; eauto. assumption.
Qed.

End INLINING_BODY_SPEC.

End INLINING_SPEC.

(** ** Relational specification of the translation of a function *)

Inductive tr_function: program -> function -> function -> Prop :=
  | tr_function_intro: forall p fenv f f' ctx,
      fenv_compat p fenv ->
      tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code) ->
      ctx.(dstk) = 0 ->
      ctx.(retinfo) = None ->
      f'.(fn_sig) = f.(fn_sig) ->
      f'.(fn_params) = sregs ctx f.(fn_params) ->
      f'.(fn_entrypoint) = spc ctx f.(fn_entrypoint) ->
      0 <= fn_stacksize f' < Ptrofs.max_unsigned ->
      tr_function p f f'.

Lemma tr_function_linkorder:
  forall cunit prog f f',
  linkorder cunit prog ->
  tr_function cunit f f' ->
  tr_function prog f f'.
Proof.
  intros. inv H0. econstructor; eauto. eapply fenv_compat_linkorder; eauto.
Qed.

Lemma transf_function_spec:
  forall cunit f f',
  transf_function (funenv_program cunit) f = OK f' ->
  tr_function cunit f f'.
Proof.
  intros. unfold transf_function in H.
  set (fenv := funenv_program cunit) in *.
  destruct (expand_function fenv f initstate) as [ctx s i] eqn:?.
  destruct (zlt (st_stksize s) Ptrofs.max_unsigned); inv H.
  monadInv Heqr. set (ctx := initcontext x x0 (max_reg_function f) (fn_stacksize f)) in *.
Opaque initstate.
  destruct INCR3. inversion EQ1. inversion EQ.
  apply tr_function_intro with fenv ctx; auto.
  apply funenv_program_compat.
  eapply expand_cfg_spec with (fe := fenv); eauto.
    red; auto.
    unfold ctx; rewrite <- H1; rewrite <- H2; rewrite <- H3; simpl. extlia.
    unfold ctx; rewrite <- H0; rewrite <- H1; simpl. extlia.
    simpl. extlia.
    simpl. apply Z.divide_0_r.
    simpl. lia.
  simpl. lia.
  simpl. split; auto. destruct INCR2. destruct INCR1. destruct INCR0. destruct INCR.
  simpl. change 0 with (st_stksize initstate). lia.
Qed.


Add LoadPath "/home/amos/applpi".

Require Import libapplpi.
Require Import SG_applpi_string.
Require Import Coq.FSets.FMapList.
Require Import Coq.Strings.String.
Import ListNotations.

Record FileSystemState : Set := file_sys_st
  {fs_st : list (string * list bool)}.

(* Helper func: search offset and return content for FS_Read *)
Fixpoint return_offset (content : list bool) (offset : nat) : option bool :=
  match offset with
    | O => match content with (* offset == 0 *)
             | [] => None
             | a :: t => Some a
           end
    | S rest => match content with (* offset != 0 and keeping searching *)
                  | [] => None
                  | a :: t => return_offset t rest
                 end
  end.

(* Helper func: search file_name in fs and return content of the offset *)
Fixpoint FS_Read (file_name : string) (offset : nat)
                   (file_st : list (string * list bool)) : option bool :=
  match file_st with
    | nil => None
    | a::t => match a with (* compare the file_name and keeping searching from fs *)
             | (s,b) => if string_dec file_name s then return_offset b offset
                        else FS_Read file_name offset t
           end
  end.

(** FS_Read_Main using FS_Read and return_offset *)
Definition FS_Read_Main (file_name : string) (offset : nat)
                          (file_st : FileSystemState) : option bool :=
  match file_st with
    | file_sys_st a => FS_Read file_name offset a
  end.

(* Helper func: search offset and write new content *)
Fixpoint write_content (content : list bool) (offset : nat)
                         (new_content : bool) : option (list bool) :=
  match offset with
    | O => match content with
             | [] => Some [new_content]
             | a :: t => Some (new_content :: t) (* write the new content and the rest appends *)
           end
    | S rest => match content with
                  | [] => None (* if the file doesn't have enough sapce, do nothing *)
                  | a :: t => match write_content t rest new_content with
                                | None => None
                                | Some b => Some (a :: b)
                              end
                 end
  end.

(* Helper func: search file_name and offset; then, write the content *)
Fixpoint FS_Write (file_name : string) (offset : nat) (content : bool)
                    (file_st : list (string * list bool)) :
                      option (list (string * list bool)) :=
  match file_st with
    | nil => None
    | a::t => match a with
             | (s,b) => if string_dec file_name s then
                            match write_content b offset content with
                              | None => None
                              | Some a => Some ((s,a)::t)
                            end
                        else match FS_Write file_name offset content t with
                               | None => None
                               | Some b => Some (a::b)
                             end
              end
  end.

(** FS_Write_Main using FS_Write and write_content *)
Definition FS_Write_Main (file_name : string)
                           (offset : nat) (content : bool)
                             (file_st : FileSystemState) : option FileSystemState :=
  match file_st with
    | file_sys_st a => match FS_Write file_name offset content a with
                         | None => None
                         | Some new => Some (file_sys_st new)
                       end
  end.

Fixpoint FS_Create (file_name : string)
                     (file_st : list (string * list bool)) :
                       option (list (string * list bool)) :=
  match file_st with
    | nil => Some [(file_name,nil)]
    | hd::tl => match hd with
                  | (name,content) => if string_dec file_name name then None
                                      else match FS_Create file_name tl with
                                             | None => None
                                             | Some a => Some (hd::a)
                                           end
                end
  end.

Definition FS_Create_Main (file_name : string)
                            (file_st : FileSystemState) :
                              option FileSystemState :=
  match file_st with
    | file_sys_st st => match FS_Create file_name st with
                          | None => None
                          | Some new => Some (file_sys_st new)
                        end
  end.

Fixpoint FS_Delete (file_name : string) (file_st : list (string * list bool)) :
                                                  option (list (string * list bool)) :=
  match file_st with
    | nil => None
    | hd::tl => match hd with
                  | (name, content) => if string_dec file_name name then Some tl
                                       else match FS_Delete file_name tl with
                                              | None => None
                                              | Some a => Some (hd::a)
                                            end
                end
  end.

Definition FS_Delete_Main (file_name : string) (file_st : FileSystemState) : option FileSystemState :=
  match file_st with
    | file_sys_st st => match FS_Delete file_name st with
                          | None => None
                          | Some new => Some (file_sys_st new)
                        end
  end.

Fixpoint FS_Rename (old_file_name : string)
                     (new_file_name : string)
                       (file_st : list (string * list bool)) :
                         option (list (string * list bool)) :=
  match file_st with
    | nil => None
    | hd::tl => match hd with
                  | (name, content) =>
                    if string_dec new_file_name name then None (* check duplicate filename *)
                    else if string_dec old_file_name name then
                            match FS_Rename old_file_name new_file_name tl with
                              | None => None
                              | Some a => Some ((new_file_name, content)::a)
                            end
                         else match FS_Rename old_file_name new_file_name tl with
                                | None => None
                                | Some a => Some (hd::a)
                              end
                end
  end.

Definition FS_Rename_Main (old_file_name : string)
                            (new_file_name : string)
                              (file_st : FileSystemState) :
                                option FileSystemState :=
  match file_st with
    | file_sys_st st => match FS_Rename old_file_name new_file_name st with
                          | None => None
                          | Some new => Some (file_sys_st new)
                        end
  end.

Fixpoint Truncate_Length (new_len : nat) (content : list bool) : option (list bool) :=
  match new_len with
    | O => Some []
    | S rest => match content with
                  | [] => None
                  | hd::tl => match Truncate_Length rest tl with
                                | None => None
                                | Some new_content => Some (hd::new_content)
                              end
                end
  end.

Fixpoint FS_Truncate (file_name : string) (new_len : nat)
                       (file_st : list (string * list bool)) :
                         option (list (string * list bool)) :=
  match file_st with
    | [] => None
    | hd::tl => match hd with
                  | (name, content) =>
                    if string_dec file_name name then
                       match Truncate_Length new_len content with
                         | None => None
                         | Some new_content => Some ((name, new_content)::tl)
                       end
                    else match FS_Truncate file_name new_len tl with
                           | None => None
                           | Some a => Some (hd::a)
                         end
                end
  end.

Definition FS_Truncate_Main (file_name : string) (new_len : nat)
                              (file_st : FileSystemState) :
                                option FileSystemState :=
  match file_st with
    | file_sys_st st => match FS_Truncate file_name new_len st with
                          | None => None
                          | Some new => Some (file_sys_st new)
                        end
  end.

Fixpoint Return_List_String (file_st : list (string * list bool)) : list string :=
  match file_st with
    | [] => []
    | hd::tl => match hd with
                  | (name, content) => (name::Return_List_String tl)
                end
  end.

(* retrieve all filenames from the file system *)
Definition Return_All_Filename (file_st : FileSystemState) : list string :=
  match file_st with
    | file_sys_st st => Return_List_String st
  end.

(* Proof: write operation doesn't change the existing file name in the file system *)
Lemma Check_Write_Doesnot_Change_Filename :
        forall file_st file_name offset content,
          match FS_Write_Main file_name offset content file_st with
            | None => True (* write fail means always true *)
            | Some new_st => Return_All_Filename new_st = Return_All_Filename file_st
          end. (* new and old file names in file system remain the same *)
intros.                                    (* introduce inductive definition *)
destruct file_st.                          (* destruct inductive data type for file_st become fs_st0 *)
simpl.                                     (* compute *)
induction fs_st0.                          (* instantiate fs_st0 into two cases *)
simpl.                                     (* case [] is trivial *)
auto.                                      (* solve the current goal *)
simpl.                                     (* bring FS_Write func in *)
destruct a.                                (* pair is also an inductive type *)
destruct (string_dec file_name s).         (* instantiate if into two cases *)
destruct (write_content l offset content). (* instantiate write_content into its cases *)
simpl.                                     (* compute *)
reflexivity.                               (* equal to *)
auto.                                      (* solve the current goal *)
destruct (FS_Write file_name offset content fs_st0). (* instantiate FS_Write into its cases *)
simpl.                                     (* compute *)
simpl in IHfs_st0.                         (* in induction, we need to use hypothesis *)
rewrite IHfs_st0.                          (* apply IHfs_st0 into current goal *)
reflexivity.                               (* equal to *)
auto.                                      (* solve the current goal *)
Qed.

(* check new string append to the current list of string *)
Fixpoint New_String_Append (list_string : list string)
                             (new_string : string) : list string :=
  match list_string with
    | [] => [new_string]
    | hd::tl => hd::New_String_Append tl new_string
  end.

(* Compare new string to the strings of the list strings in the way of bubble sort *)
Fixpoint Check_StringUnique_List (new_string : string)
                                   (list_string : list string) : Prop :=
  match list_string with
    | [] => True
    | hd::tl => ~(new_string = hd) /\ Check_StringUnique_List new_string tl
  end.

(* check all strings are unique in the list strings *)
Fixpoint Check_AllStringUnique_List (list_string : list string) : Prop :=
  match list_string with
    | [] => True
    | hd::tl => Check_StringUnique_List hd tl /\ Check_AllStringUnique_List tl
  end.

(* check all filenames are unique when input is FileSystemState *)
Definition Check_Filename_Unique (file_st : FileSystemState) : Prop :=
  Check_AllStringUnique_List (Return_All_Filename file_st).

(* Proof: write operation doesn't violate the property that all filenames are unique *)
Lemma Check_Write :
        forall file_st file_name offset content,
          Check_Filename_Unique file_st ->
            match FS_Write_Main file_name offset content file_st with
              | None => True (* write fail means always true *)
              | Some a => Check_Filename_Unique a
            end. (* all filenames are unique after write operation *)
intros.                                                       (* introduce inductive definition *)
destruct file_st.                                             (* destruct inductive data type for file_st become fs_st0 *)
simpl.                                                        (* go into FS_Write_Main *)
pose Check_Write_Doesnot_Change_Filename.                     (* apply other lemma in this proof *)
specialize (y (file_sys_st fs_st0) file_name offset content). (* bring concrete terms for universal quantification of lemma; name new one as y *)
simpl in y.                                                   (* compute for y*)
destruct (FS_Write file_name offset content fs_st0).          (* instantiate FS_write into its cases *)
simpl in y.                                                   (* compute for y *)
unfold Check_Filename_Unique.                                 (* bring function in *)
unfold Return_All_Filename.                                   (* can be replaced by simpl *)
unfold Check_Filename_Unique in H.                            (* bring function in H *)
unfold Return_All_Filename in H.                              (* can be replace by simpl in H *)
rewrite y.                                                    (* apply y into our goal *)
auto.                                                         (* compute *)
auto.                                                         (* solve the current goal *)
Qed.

(* ref: https://github.com/xu-hao/CertifiedQueryArrow/blob/master/Algebra/Utils.v Line:491 *)
Section NatListDoubleInductionPrinciple.
    Variable
      (T : Type)
      (P : nat ->  list T  -> Prop)
      (onil : P 0   nil)
      (ocons : forall a b, P 0 b -> P 0 (a :: b))
      (snil : forall b, P b List.nil -> P (S b) List.nil)
      (scons : forall b c d, P b d -> P (S b) (c :: d)).

    Fixpoint nat_list_ind_2
             (l1 : nat) ( l2 : list T) : P l1 l2 :=
      match l1 in nat return P l1 l2 with
        | 0 =>
          (fix h' (l2' : list T) : P 0 l2' :=
             match l2' with
               | List.nil => onil
               | a :: b => ocons a b (h' b)
             end) l2
        | S b =>
          (fix h' (l2' : list T) : P (S b) l2' :=
             match l2' with
               | List.nil => snil b (nat_list_ind_2 b nil)
               | c :: d => scons b c d (nat_list_ind_2 b d)
             end) l2
      end
    .
End NatListDoubleInductionPrinciple.

(* Proof: check written content by write_content is the same as the content returned by return_offset *)
Lemma check_written_content_sameas_newcontent:
        forall list_content offset content,
          match write_content list_content offset content with
            | None => True
            | Some a => return_offset a offset = Some content
          end.
intros.
generalize offset list_content.
clear list_content offset.
apply nat_list_ind_2.
simpl.
reflexivity.
intros.
simpl.
auto.
intros.
simpl.
auto.
intros.
simpl.
destruct (write_content d b content).
simpl.
assumption.
auto.
Qed.

(* Proof: Always read latest written file -
   A content c, written by write operation to a file_name f with a offset o,
   is the same as read operation return by reading f with o *)
Lemma Read_After_Write :
        forall file_st file_name offset content,
          match FS_Write_Main file_name offset content file_st with
            | None => True (* write fail means always true *)
            | Some a => match FS_Read_Main file_name offset a with
                          | None => True
                          | Some return_content => return_content = content
                        end
          end.
intros.
destruct file_st.
simpl.
induction fs_st0.
simpl.
auto.
simpl.
destruct a.
destruct (string_dec file_name s).
destruct (write_content l offset content) eqn: H.
simpl.
destruct (string_dec file_name s). (* write_content l offset content = Some l0, match return_offset l0 offset with *)
pose check_written_content_sameas_newcontent.
specialize (y l offset content).
rewrite H in y.
rewrite y.
reflexivity.
contradiction.
auto.
destruct (FS_Write file_name offset content fs_st0).
simpl.
destruct (string_dec file_name s).
contradiction.
assumption.
auto.
Qed.

(* Proof: truncate operation doesn't change the existing file name in the file system *)
Lemma Truncate_Doesnot_Change_Filename :
        forall file_st file_name length,
          match FS_Truncate_Main file_name length file_st with
            | None => True (* truncate fail means always true *)
            | Some new_st => Return_All_Filename new_st = Return_All_Filename file_st
          end. (* new and old file names in file system remain the same *)
intros.
destruct file_st.
simpl.
induction fs_st0.
simpl.
auto.
simpl.
destruct a.
destruct (string_dec file_name s).
destruct (Truncate_Length length l).
simpl.
reflexivity.
auto.
destruct (FS_Truncate file_name length fs_st0).
simpl.
simpl in IHfs_st0.
rewrite IHfs_st0.
reflexivity.
auto.
Qed.

(* Proof: truncate operation doesn't violate the property that all filenames are unique *)
Lemma Check_Truncate :
        forall file_st file_name length,
          Check_Filename_Unique file_st ->
            match FS_Truncate_Main file_name length file_st with
              | None => True (* truncate fail means always true *)
              | Some a => Check_Filename_Unique a
            end. (* all filenames are unique after write operation *)
intros.
destruct file_st.
simpl.
pose Truncate_Doesnot_Change_Filename.
specialize (y (file_sys_st fs_st0) file_name length).
simpl in y.
destruct (FS_Truncate file_name length fs_st0).
simpl in y.
unfold Check_Filename_Unique.
unfold Return_All_Filename.
unfold Check_Filename_Unique in H.
unfold Return_All_Filename in H.
rewrite y.
auto.
auto.
Qed.

(* Proof: create operation always append new filename in the end *)
Lemma Check_Create_Append:
        forall file_st file_name,
          match FS_Create_Main file_name file_st with
            | None => True (* create fail means always true *)
            | Some new_st =>
                New_String_Append (Return_All_Filename file_st) file_name = Return_All_Filename new_st
          end. (* new and old file names in file system remain the same *)
intros.                                (* introduce inductive definition *)
destruct file_st.                      (* destruct inductive data type for file_st become fs_st0 *)
simpl.                                 (* compute *)
induction fs_st0.                      (* instantiate fs_st0 into two cases *)
simpl.                                 (* case [] is trivial *)
reflexivity.                           (* equal to *)
simpl.                                 (* go into FS_Create *)
destruct a.                            (* pair is also an inductive type *)
destruct (string_dec file_name s).     (* instantiate if into two cases *)
auto.                                  (* solve the current goal *)
destruct (FS_Create file_name fs_st0). (* instantiate FS_Create into its cases *)
simpl.                                 (* compute *)
simpl in IHfs_st0.                     (* in induction, we need to use hypothesis *)
rewrite IHfs_st0.                      (* apply IHfs_st0 into current goal *)
reflexivity.                           (* equal to *)
auto.                                  (* solve the current goal *)
Qed.

(* Proof: create operation always create unique filename in the existing file system *)
Lemma Create_UniqueOne_inFileSys :
        forall file_st file_name,
          match FS_Create_Main file_name file_st with
            | None => True (* truncate fail means always true *)
            | Some a => Check_StringUnique_List file_name (Return_All_Filename file_st)
          end. (* all filenames are unique after create operation *)
intros.
destruct file_st.
simpl.
induction fs_st0.
simpl.
auto.
simpl.
destruct a.
destruct (string_dec file_name s).
auto.
destruct (FS_Create file_name fs_st0).
simpl.
split.
auto.
apply IHfs_st0.
auto.
Qed.

(* Proof: created file is always append and unique *)
Lemma Create_File_AppendUnique :
        forall file_st file_name,
          match FS_Create_Main file_name file_st with
            | None => True (* truncate fail means always true *)
            | Some new_st =>
                Check_StringUnique_List file_name (Return_All_Filename file_st) /\
                New_String_Append (Return_All_Filename file_st) file_name = Return_All_Filename new_st
          end. (* all filenames are unique after create operation *)
intros.
pose Check_Create_Append.
specialize (y file_st file_name).
pose Create_UniqueOne_inFileSys.
specialize (y0 file_st file_name).
destruct (FS_Create_Main file_name file_st).
tauto.
auto.
Qed.

(* Proof: New_String_Append func doesn't violate the property that all strings are unique *)
(* 1. The new string is diffent from any string in the esisting string list *)
(* 2. The strings in the existing string list are unique *)
Lemma Check_CreatedString :
        forall old_string_list file_name,
          Check_StringUnique_List file_name old_string_list ->
            Check_AllStringUnique_List old_string_list ->
              Check_AllStringUnique_List (New_String_Append old_string_list file_name).
intros.                                 (* introduce inductive definition *)
induction old_string_list.              (* instantiate old_string_list into two cases *)
simpl.
tauto.                                  (* prove true *)
simpl.
simpl in H.
simpl in H0.
split.                                  (* split goal into two cases *)
destruct H0.                            (* break H0 down *)
destruct H.                             (* break H down *)
clear H1 H2 IHold_string_list.          (* clear hypothesis, but why? *)
induction old_string_list.              (* instantiate old_string_list into two cases *)
simpl.
split.                                  (* split goal into two cases *)
intro.                                  (* same as hypothesis *)
apply H.
symmetry.                               (* form t = u to u = t *)
assumption.                             (* type is equal to the goal *)
auto.
simpl.
simpl in H0.
destruct H0.                            (* break H0 down *)
split.                                  (* split goal into two cases *)
assumption.                             (* type is equal to the goal *)
apply IHold_string_list.                (* become the precondition *)
assumption.                             (* type is equal to the goal, H1 *)
apply IHold_string_list.                (* become the precondition *)
tauto.
tauto.
Qed.

(* Proof: create operation doesn't violate the property that all filenames are unique *)
Lemma Check_Create :
        forall file_st file_name,
          Check_Filename_Unique file_st ->
            match FS_Create_Main file_name file_st with
              | None => True (* truncate fail means always true *)
              | Some new_st => Check_AllStringUnique_List (Return_All_Filename new_st)
            end. (* all filenames are unique after create operation *)
intros.
pose Create_File_AppendUnique.
specialize (y file_st file_name).
destruct (FS_Create_Main file_name file_st).
destruct y.
rewrite <- H1.
apply Check_CreatedString.
assumption.
assumption.
auto.
Qed.

(* delete a string from the current list of string *)
Fixpoint Delete_String_List (list_string : list string) (delete_name : string) : list string :=
  match list_string with
    | [] => []
    | hd::tl => if string_dec delete_name hd then tl
                                             else hd::Delete_String_List tl delete_name
  end.

(* Proof: delete operation doesn't change the existing file name in the file system *)
Lemma Delete_Doesnot_Change_Filename :
        forall file_st file_name,
          match FS_Delete_Main file_name file_st with
            | None => True (* delete fail means always true *)
            | Some new_st =>
                Delete_String_List (Return_All_Filename file_st) file_name = Return_All_Filename new_st
          end. (* rest filenames doesn't change  *)
intros.
destruct file_st.
simpl.
induction fs_st0.
simpl.
auto.
simpl.
destruct a.
simpl.
destruct (string_dec file_name s).
reflexivity.
destruct (FS_Delete file_name fs_st0).
rewrite IHfs_st0.
reflexivity.
auto.
Qed.

(* Proof: after deleting one string from the string list, the rest strings of the string list are unique *)
Lemma StringUnique_AfterDeleteOneString :
        forall old_string_list file_name delete_name,
          Check_StringUnique_List file_name old_string_list ->
            Check_StringUnique_List file_name (Delete_String_List old_string_list delete_name).
intros.
induction old_string_list.
simpl.
auto.
simpl.
destruct (string_dec file_name a).
destruct (string_dec delete_name a).
simpl in H.
destruct H.
assumption.
simpl.
split.
simpl in H.
destruct H.
assumption.
apply IHold_string_list.
simpl in H.
destruct H.
assumption.
destruct (string_dec delete_name a).
simpl in H.
destruct H.
assumption.
simpl.
split.
simpl in H.
destruct H.
assumption.
apply IHold_string_list.
simpl in H.
destruct H.
assumption.
Qed.

(* Proof: a list of string still unique after delete one string *)
Lemma StringsUnique_AfterDelete :
        forall old_string_list file_name,
          Check_AllStringUnique_List old_string_list ->
            Check_AllStringUnique_List (Delete_String_List old_string_list file_name).
intros.
induction old_string_list.
simpl.
auto.
simpl.
destruct (string_dec file_name a).
simpl in H.
destruct H.
assumption.
simpl.
split.
simpl in H.
destruct H.
apply StringUnique_AfterDeleteOneString.
assumption.
apply IHold_string_list.
simpl in H.
destruct H.
assumption.
Qed.

(* Proof: delete operation doesn't violate the property that all filenames are unique *)
Lemma Check_Delete :
        forall file_st file_name,
          Check_Filename_Unique file_st ->
            match FS_Delete_Main file_name file_st with
              | None => True (* truncate fail means always true *)
              | Some new_st => Check_AllStringUnique_List (Return_All_Filename new_st)
            end. (* all filenames are unique after delete operation *)
intros.
pose Delete_Doesnot_Change_Filename.
specialize (y file_st file_name).
destruct (FS_Delete_Main file_name file_st).
rewrite <- y.
apply StringsUnique_AfterDelete.
assumption.
auto.
Qed.

(* rename a string from the current list of string *)
Fixpoint Rename_aString_inList (old_name : string) (new_name : string)
                                                   (list_string : list string) : list string :=
  match list_string with
    | [] => []
    | hd::tl => if string_dec new_name hd then hd::tl (* check the duplicate string *)
                else if string_dec old_name hd then new_name::(Rename_aString_inList old_name new_name tl)
                else hd::Rename_aString_inList old_name new_name tl
  end.

(* Proof: rename operation doesn't change the other original file name in the file system *)
Lemma Rename_Doesnot_Change_Filename :
        forall old_name new_name file_st,
          match FS_Rename_Main old_name new_name file_st with
            | None => True (* delete fail means always true *)
            | Some new_st =>
                Rename_aString_inList old_name new_name (Return_All_Filename file_st) =
                                                                        Return_All_Filename new_st
          end. (* the other filenames doesn't change  *)
intros.
destruct file_st.
simpl.
induction fs_st0.
simpl.
auto.
simpl.
destruct a.
destruct (string_dec new_name s).
auto.
destruct (string_dec old_name s).
destruct (FS_Rename old_name new_name fs_st0) eqn:?. (* destruct term but left term's relation *)
simpl in IHfs_st0.
simpl.
destruct (string_dec new_name s).
contradiction.                                       (* new_name <> s && new_name = s *)
destruct (string_dec old_name s).
rewrite IHfs_st0.
reflexivity.
contradiction.
auto.
destruct (FS_Rename old_name new_name fs_st0).
simpl.
destruct (string_dec new_name s).
contradiction.
destruct (string_dec old_name s).
contradiction.
simpl in IHfs_st0.
rewrite <- IHfs_st0.
reflexivity.
auto.
Qed.

(* Proof: The NewName of the rename operation is different from the string lists *)
Lemma NewName_isUnique :
        forall file_st old_name new_name,
          Check_Filename_Unique file_st ->
            match FS_Rename_Main old_name new_name file_st with
              | None => True (* rename fail means always true *)
              | Some new_st => Check_StringUnique_List new_name (Return_All_Filename file_st)
            end.
intros.
destruct file_st.
simpl.
induction fs_st0.
simpl.
auto.
simpl.
destruct a.
destruct (string_dec new_name s).
auto.
destruct (string_dec old_name s).
destruct (FS_Rename old_name new_name fs_st0).
simpl.
split.
assumption.
apply IHfs_st0.
unfold Check_Filename_Unique.
unfold Check_Filename_Unique in H.
simpl in H.
destruct H.
assumption.
auto.
destruct (FS_Rename old_name new_name fs_st0).
simpl.
split.
assumption.
apply IHfs_st0.
unfold Check_Filename_Unique.
unfold Check_Filename_Unique in H.
simpl in H.
destruct H.
assumption.
auto.
Qed.

(* rename a string from the current list of string, but has different form; it's v2 *)
Fixpoint Rename_aString_inList_v2 (old_name : string) (new_name : string) (list_string : list string)
                                                      {struct list_string}: list string :=
  match list_string with
    | [] => []
    | hd::tl => if string_dec new_name hd then hd::tl (* check the duplicate string *)
                else if string_dec old_name hd then new_name::tl
                else hd::Rename_aString_inList_v2 old_name new_name tl
  end.

(* If the new_name and old_name don't match each other, the string_list remains the same *)
Lemma RenamedNames_NotMatch :
        forall old_name new_name string_list,
          Check_StringUnique_List old_name string_list ->
            Rename_aString_inList old_name new_name string_list = string_list.
intros.
induction string_list.
reflexivity.
simpl.
destruct H.
destruct (string_dec new_name a).
reflexivity.
destruct (string_dec old_name a).
contradiction.
rewrite IHstring_list.
reflexivity.
assumption.
Qed.

(* Proof: Rename_aString_inList v1 and v2 behave the same *)
Lemma Rename_Version_Equal :
        forall old_name new_name string_list,
          Check_AllStringUnique_List string_list ->
            Check_StringUnique_List new_name string_list ->
              Rename_aString_inList old_name new_name string_list =
                                    Rename_aString_inList_v2 old_name new_name string_list.
intros.
induction string_list.
reflexivity.
simpl.
simpl in H.
simpl in H0.
destruct (string_dec new_name a).
destruct H0.
contradiction.
destruct (string_dec old_name a). (*Check_StringUnique_List old_name string_list -> Rename_aString_inList old_name new_name string_list = string_list*)
rewrite RenamedNames_NotMatch.
reflexivity.
rewrite e.
destruct H.
auto.
rewrite IHstring_list.
reflexivity.
tauto.
tauto.
Qed.

(* Proof: after renaming old_name to new_name, unique_name is still unique *)
Lemma rename_neq_unique :
        forall unique_name old_name new_name string_list,
          unique_name <> new_name ->
            Check_StringUnique_List unique_name string_list ->
              Check_StringUnique_List unique_name (Rename_aString_inList_v2 old_name new_name string_list).
intros.
induction string_list.
simpl.
auto.
simpl.
simpl in H0.
destruct H0.
destruct (string_dec new_name a).
rewrite <- e.
simpl.
tauto.
destruct (string_dec old_name a).
simpl.
tauto.
simpl.
tauto.
Qed.

(* All strings are unique after rename old_name to new_name in the list of strings *)
Lemma AllString_Unique_AfterRenameAString :
        forall file_st old_name new_name,
          Check_Filename_Unique file_st ->
            match FS_Rename_Main old_name new_name file_st with
              | None => True (* rename fail means always true *)
              | Some new_st =>
                  Check_AllStringUnique_List (Rename_aString_inList old_name new_name (Return_All_Filename file_st))
            end.
intros.
pose NewName_isUnique.
specialize (y file_st old_name new_name).
destruct (FS_Rename_Main old_name new_name file_st).
rewrite Rename_Version_Equal.
destruct file_st.
simpl.
specialize (y H).
simpl in y.
induction fs_st0.
simpl.
auto.
simpl.
destruct a.
unfold Check_Filename_Unique in H.
simpl in H.
simpl.
destruct (string_dec new_name s).
auto.
destruct (string_dec old_name s).
simpl.
split.
simpl in y.
tauto.
destruct H.
assumption.
destruct H.
simpl.
split.
apply rename_neq_unique.
intros.
intro.
apply n.
symmetry.
assumption.
assumption.
apply IHfs_st0.
assumption.
destruct y.
assumption.
auto.
auto.
auto.
Qed.

(* Proof: rename operation doesn't violate the property that all filenames are unique *)
(*Lemma Check_Rename :
          forall file_st old_name new_name,
            Check_Filename_Unique file_st ->
              match FS_Rename_Main old_name new_name file_st with
                | None => True (* rename fail means always true *)
                | Some new_st => Check_AllStringUnique_List (Return_All_Filename new_st)
              end. (* all filenames are unique after rename operation *)
intros.
pose Rename_Doesnot_Change_Filename.
specialize (y old_name new_name file_st).
destruct (FS_Rename_Main old_name new_name file_st).
rewrite <- y.
pose AllString_Unique_AfterRenameAString.
specialize (y0 file_st old_name new_name).
destruct (FS_Rename_Main old_name new_name file_st).
apply y0.
assumption.

destruct f.
simpl.
destruct file_st.
simpl in H.*)


(* Instantiation *)
(* see https://webassembly.github.io/spec/core/exec/modules.html#exec-instantiation *)
(* (C) J. Pichon, M. Bodin - see LICENSE.txt *)

From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From ITree Require Import ITree.
From ITree Require ITreeFacts.
From Wasm Require Import list_extra datatypes datatypes_properties
                         interpreter binary_format_parser operations
                         typing opsem type_checker memory memory_list.
From Coq Require Import BinNat.

(* TODO: Documentation *)

(* TODO: separate algorithmic aspects from specification, incl. dependencies *)

(* TODO: get rid of old notation that doesn't follow standard *)

Section Host.

Variable host_function : eqType.
Let host := host host_function.

Variable host_instance : host.

Let store_record_eq_dec := @store_record_eq_dec host_function.
Let store_record_eqType := @store_record_eqType host_function.

(* Before adding a canonical structure to [name], we save the base one to ensure better extraction. *)
Local Canonical Structure name_eqType := Eval hnf in EqType name (seq_eqMixin _).

Let store_record := store_record host_function.
(*Let administrative_instruction := administrative_instruction host_function.*)
Let host_state := host_state host_instance.

Let executable_host := executable_host host_function.
Variable executable_host_instance : executable_host.
Let host_event := host_event executable_host_instance.

Context {eff : Type -> Type}.
Context {eff_has_host_event : host_event -< eff}.

Let run_v {eff' eff'_has_host_event} :=
  @interpreter.run_v _ executable_host_instance eff' eff'_has_host_event.

Definition addr := nat.
Definition funaddr := addr.
Definition tableaddr := addr.
Definition memaddr := addr.
Definition globaladdr := addr.

Definition alloc_Xs {A B} f (s : store_record) (xs : list A) : store_record * list B :=
  let '(s', fas) :=
    List.fold_left
      (fun '(s, ys) x =>
        let '(s', y) := f s x in
        (s', y :: ys))
        xs
        (s, nil) in
  (s', List.rev fas).

Inductive externval : Type :=
| ev_func : funaddr -> externval
| ev_table : tableaddr -> externval
| ev_mem : memaddr -> externval
| ev_global : globaladdr -> externval.

Definition funcs_of_externals (evs : list externval) : list addr :=
  seq.pmap (fun ev => match ev with | ev_func fa => Some fa | _ => None end) evs.

Definition tables_of_externals (evs : list externval) : list addr :=
  seq.pmap (fun ev => match ev with | ev_table ta => Some ta | _ => None end) evs.

Definition mems_of_externals (evs : list externval) : list addr :=
  seq.pmap (fun ev => match ev with | ev_mem ta => Some ta | _ => None end) evs.

Definition globals_of_externals (evs : list externval) : list addr :=
  seq.pmap (fun ev => match ev with | ev_global ta => Some ta | _ => None end) evs.

Definition add_func (s : store_record) funcinst := {|
  s_funcs := List.app s.(s_funcs) [::funcinst];
  s_tables := s.(s_tables);
  s_mems := s.(s_mems);
  s_globals := s.(s_globals);
|}.

Definition alloc_func (s : store_record) (m_f : module_func) (mi : instance) : store_record * funcidx :=
  let funcaddr := List.length s.(s_funcs) in
  let functype := List.nth (match m_f.(modfunc_type) with | Mk_typeidx n => n end) mi.(inst_types) (Tf nil nil (* TODO: partiality problem *) ) in
  let funcinst := FC_func_native mi functype m_f.(modfunc_locals) m_f.(modfunc_body) in
  let S' := add_func s funcinst in
  (S', Mk_funcidx funcaddr).

Definition alloc_funcs (s : store_record) (m_fs : list module_func) (mi : instance) : store_record * list funcidx :=
  alloc_Xs (fun s m_f => alloc_func s m_f mi) s m_fs.

Definition add_table (s : store_record) (ti : tableinst) : store_record := {|
  s_funcs := s.(s_funcs);
  s_tables := List.app s.(s_tables) [::ti];
  s_mems := s.(s_mems);
  s_globals := s.(s_globals);
|}.

Definition alloc_tab (s : store_record) (tty : table_type) : store_record * tableidx :=
  let '{| tt_limits := {| lim_min := min; lim_max := maxo |} as lim; tt_elem_type := ety |} := tty in
  let tableaddr := Mk_tableidx (List.length s.(s_tables)) in
  let tableinst := {|
    table_data := (List.repeat None min);
    table_max_opt := maxo;
  |} in
  (add_table s tableinst, tableaddr).

Definition alloc_tabs (s : store_record) (ts : list table_type) : store_record * list tableidx :=
  alloc_Xs alloc_tab s ts.

Definition mem_mk (lim : limits) : memory :=
  let len := BinNatDef.N.mul page_size lim.(lim_min) in
  {| mem_data := mem_make Integers.Byte.zero len;
    mem_max_opt := lim.(lim_max);
  |}.

Definition add_mem (s : store_record) (m_m : memory) : store_record := {|
  s_funcs := s.(s_funcs);
  s_tables := s.(s_tables);
  s_mems := List.app s.(s_mems) [::m_m];
  s_globals := s.(s_globals);
|}.

Definition alloc_mem (s : store_record) (m_m : memory_type) : store_record * memidx :=
  let '{| lim_min := min; lim_max := maxo |} := m_m in
  let memaddr := Mk_memidx (List.length s.(s_mems)) in
  let meminst := mem_mk m_m in
  (add_mem s meminst, memaddr).

Definition alloc_mems (s : store_record) (m_ms : list memory_type) : store_record * list memidx :=
  alloc_Xs alloc_mem s m_ms.

Definition add_glob (s : store_record) (m_g : global) : store_record := {|
  s_funcs := s.(s_funcs);
  s_tables := s.(s_tables);
  s_mems := s.(s_mems);
  s_globals := List.app s.(s_globals) [::m_g];
|}.

Definition alloc_glob (s : store_record) (m_g_v : module_glob * value) : store_record * globalidx :=
  let '(m_g, v) := m_g_v in
  let globaddr := Mk_globalidx (List.length s.(s_globals)) in
  let globinst := Build_global m_g.(modglob_type).(tg_mut) v in
  (add_glob s globinst, globaddr).

Definition alloc_globs s m_gs vs :=
  alloc_Xs alloc_glob s (List.combine m_gs vs).

(* TODO: lemmas *)

Definition v_ext := module_export_desc.

Definition export_get_v_ext (inst : instance) (exp : module_export_desc) : v_ext :=
  (* we circumvent partiality by providing 0 as a default *)
  match exp with
  | MED_func (Mk_funcidx i) => MED_func (Mk_funcidx (List.nth i inst.(inst_funcs) 0))
  | MED_table (Mk_tableidx i) => MED_table (Mk_tableidx (List.nth i inst.(inst_tab) 0))
  | MED_mem (Mk_memidx i) => MED_mem (Mk_memidx (List.nth i inst.(inst_memory) 0))
  | MED_global (Mk_globalidx i) => MED_global (Mk_globalidx (List.nth i inst.(inst_globs) 0))
  end.

Definition ext_funcs :=
  seq.pmap
    (fun x =>
      match x with
      | MED_func i => Some i
      | _ => None
      end).

Definition ext_tabs :=
  seq.pmap
    (fun x =>
      match x with
      | MED_table i => Some i
      | _ => None
      end).

Definition ext_mems :=
  seq.pmap
    (fun x =>
      match x with
      | MED_mem i => Some i
      | _ => None
      end).

Definition ext_globs :=
  seq.pmap
    (fun x =>
      match x with
      | MED_global i => Some i
      | _ => None
      end).

Definition ext_t_funcs :=
  seq.pmap
    (fun x =>
      match x with
      | ET_func tf => Some tf
      | _ => None
      end).

Definition ext_t_tabs :=
  seq.pmap
    (fun x =>
      match x with
      | ET_tab i => Some i
      | _ => None
      end).

Definition ext_t_mems :=
  seq.pmap
    (fun x =>
      match x with
      | ET_mem i => Some i
      | _ => None
      end).

Definition ext_t_globs :=
  seq.pmap
    (fun x =>
      match x with
      | ET_glob i => Some i
      | _ => None
      end).

Definition alloc_module (s : store_record) (m : module) (imps : list v_ext) (gvs : list value)
    (s'_inst_exps : store_record * instance * seq module_export) : bool :=
  let '(s'_goal, inst, exps) := s'_inst_exps in
  let '(s1, i_fs) := alloc_funcs s m.(mod_funcs) inst in
  let '(s2, i_ts) := alloc_tabs s1 (List.map (fun t => t.(modtab_type)) m.(mod_tables)) in
  let '(s3, i_ms) := alloc_mems s2 m.(mod_mems) in
  let '(s', i_gs) := alloc_globs s3 m.(mod_globals) gvs in
  (s'_goal == s') &&
  (inst.(inst_types) == m.(mod_types)) &&
  (inst.(inst_funcs) == List.map (fun '(Mk_funcidx i) => i) (List.app (ext_funcs imps) i_fs)) &&
  (inst.(inst_tab) == List.map (fun '(Mk_tableidx i) => i) (List.app (ext_tabs imps) i_ts)) &&
  (inst.(inst_memory) == List.map (fun '(Mk_memidx i) => i) (List.app (ext_mems imps) i_ms)) &&
  (inst.(inst_globs) == List.map (fun '(Mk_globalidx i) => i) (List.app (ext_globs imps) i_gs)) &&
  (exps == (List.map (fun m_exp => {| modexp_name := m_exp.(modexp_name); modexp_desc := (export_get_v_ext inst m_exp.(modexp_desc)) |}) m.(mod_exports) : seq module_export)).

Definition interp_alloc_module (s : store_record) (m : module) (imps : list v_ext) (gvs : list value) : (store_record * instance * list module_export) :=
  let i_fs := List.map (fun i => Mk_funcidx i) (seq.iota (List.length s.(s_funcs)) (List.length m.(mod_funcs))) in
  let i_ts := List.map (fun i => Mk_tableidx i) (seq.iota (List.length s.(s_tables)) (List.length m.(mod_tables))) in
  let i_ms := List.map (fun i => Mk_memidx i) (seq.iota (List.length s.(s_mems)) (List.length m.(mod_mems))) in
  let i_gs := List.map (fun i => Mk_globalidx i) (seq.iota (List.length s.(s_globals)) (min (List.length m.(mod_globals)) (List.length gvs))) in
  let inst := {|
    inst_types := m.(mod_types);
    inst_funcs := List.map (fun '(Mk_funcidx i) => i) (List.app (ext_funcs imps) i_fs);
    inst_tab := List.map (fun '(Mk_tableidx i) => i) (List.app (ext_tabs imps) i_ts);
    inst_memory := List.map (fun '(Mk_memidx i) => i) (List.app (ext_mems imps) i_ms);
    inst_globs := List.map (fun '(Mk_globalidx i) => i) (List.app (ext_globs imps) i_gs);
  |} in
  let '(s1, _) := alloc_funcs s m.(mod_funcs) inst in
  let '(s2, _) := alloc_tabs s1 (List.map (fun t => t.(modtab_type)) m.(mod_tables)) in
  let '(s3, _) := alloc_mems s2 m.(mod_mems) in
  let '(s', _) := alloc_globs s3 m.(mod_globals) gvs in
  let exps := List.map (fun m_exp => {| modexp_name := m_exp.(modexp_name); modexp_desc := export_get_v_ext inst m_exp.(modexp_desc) |}) m.(mod_exports) in
  (s', inst, exps).

(* TODO: lemmas *)

Definition insert_at {A} (v : A) (n : nat) (l : list A) : list A :=
List.app (List.firstn n l) (List.app [::v] (List.skipn (n + 1) l)).

Definition dummy_table := {| table_data := nil; table_max_opt := None; |}.

Definition init_tab (s : store_record) (inst : instance) (e_ind : nat) (e : module_element) : store_record :=
  let t_ind := List.nth (match e.(modelem_table) with Mk_tableidx i => i end) inst.(inst_tab) 0 in
  let '{|table_data := tab_e; table_max_opt := maxo |} := List.nth t_ind s.(s_tables) dummy_table in
  let e_pay := List.map (fun i => List.nth_error inst.(inst_funcs) (match i with Mk_funcidx j => j end)) e.(modelem_init) in
  let tab'_e := List.app (List.firstn e_ind tab_e) (List.app e_pay (List.skipn (e_ind + length e_pay) tab_e)) in
  {| s_funcs := s.(s_funcs);
     s_tables := insert_at {| table_data := tab'_e; table_max_opt := maxo |} t_ind s.(s_tables);
     s_mems := s.(s_mems);
     s_globals := s.(s_globals) |}.

Definition init_tabs (s : store_record) (inst : instance) (e_inds : list nat) (es : list module_element) : store_record :=
  List.fold_left (fun s' '(e_ind, e) => init_tab s' inst e_ind e) (List.combine e_inds es) s.

Definition dummy_data_vec :=
  mem_make Integers.Byte.zero (N.zero).

Definition dummy_mem := {|
  mem_data := dummy_data_vec;
  mem_max_opt := None
|}.

Definition init_mem (s : store_record) (inst : instance) (d_ind : N) (d : module_data) : store_record :=
  let m_ind := List.nth (match d.(moddata_data) with Mk_memidx i => i end) inst.(inst_memory) 0 in
  let mem := List.nth m_ind s.(s_mems) dummy_mem in
  let d_pay := List.map bytes.compcert_byte_of_byte d.(moddata_init) in
  let mem'_e := List.app (List.firstn d_ind mem.(mem_data).(ml_data)) (List.app d_pay (List.skipn (d_ind + length d_pay) mem.(mem_data).(ml_data))) in
  let mems' := insert_at {| mem_data := {| ml_data := mem'_e; ml_init := #00 |}; mem_max_opt := mem.(mem_max_opt) |} m_ind s.(s_mems) in
  {| s_funcs := s.(s_funcs);
     s_tables := s.(s_tables);
     s_mems := mems';
     s_globals := s.(s_globals); |}.

Definition init_mems (s : store_record) (inst : instance) (d_inds : list N) (ds : list module_data) : store_record :=
  List.fold_left (fun s' '(d_ind, d) => init_mem s' inst d_ind d) (List.combine d_inds ds) s.

Definition module_func_typing (c : t_context) (m : module_func) (tf : function_type) : Prop :=
  let '{| modfunc_type := Mk_typeidx i; modfunc_locals := t_locs; modfunc_body := b_es |} := m in
  let '(Tf tn tm) := tf in
  i < List.length c.(tc_types_t) /\
  List.nth i c.(tc_types_t) (Tf nil nil) == tf /\
  let c' := {|
    tc_types_t := c.(tc_types_t);
    tc_func_t := c.(tc_func_t);
    tc_global := c.(tc_global);
    tc_table := c.(tc_table);
    tc_memory := c.(tc_memory);
    tc_local := c.(tc_local) ++ tn ++ t_locs;
    tc_label := tm :: c.(tc_label);
    tc_return := Some tm;
  |} in
  typing.be_typing c' b_es (Tf [::] tm).

Definition limit_typing (lim : limits) (k : N) : bool :=
  let '{| lim_min := min; lim_max := maxo |} := lim in
  (N.leb k (N.pow 2 32)) &&
  (match maxo with None => true | Some max => N.leb max k end) &&
  (match maxo with None => true | Some max => N.leb min k end).

Definition module_tab_typing (t : module_table) : bool :=
  limit_typing t.(modtab_type).(tt_limits) (N.pow 2 32).

Definition module_mem_typing (m : memory_type) : bool :=
  limit_typing m (N.pow 2 32).

Definition const_expr (c : t_context) (b_e : basic_instruction) : bool :=
  match b_e with
  | BI_const _ => true
  | BI_get_global k =>
    (k < length c.(tc_global)) &&
    match List.nth_error c.(tc_global) k with
    | None => false
    | Some t => t.(tg_mut) == MUT_immut
    end
  | _ => false
  end.

Definition const_exprs (c : t_context) (es : list basic_instruction) : bool :=
  seq.all (const_expr c) es.

Definition module_glob_typing (c : t_context) (g : module_glob) (tg : global_type) : Prop :=
  let '{| modglob_type := tg'; modglob_init := es |} := g in
  const_exprs c es /\
  tg = tg' /\
  typing.be_typing c es (Tf nil [::tg.(tg_t)]).

Definition module_elem_typing (c : t_context) (e : module_element) : Prop :=
  let '{| modelem_table := Mk_tableidx t; modelem_offset := es; modelem_init := is_ |} := e in
  const_exprs c es /\
  typing.be_typing c es (Tf nil [::T_i32]) /\
  t < List.length c.(tc_table) /\
  seq.all (fun '(Mk_funcidx i) => i < List.length c.(tc_func_t)) is_.

Definition module_data_typing (c : t_context) (m_d : module_data) : Prop :=
  let '{| moddata_data := Mk_memidx d; moddata_offset := es; moddata_init := bs |} := m_d in
  const_exprs c es /\
  typing.be_typing c es (Tf nil [::T_i32]) /\
  d < List.length c.(tc_memory).

Definition module_start_typing (c : t_context) (ms : module_start) : bool :=
  let '(Mk_funcidx i) := ms.(modstart_func) in
  (i < length c.(tc_func_t)) &&
  match List.nth_error c.(tc_func_t) i with
  | None => false
  | Some tf => tf == (Tf nil nil)
  end.

Definition module_import_typing (c : t_context) (d : import_desc) (e : extern_t) : bool :=
  match (d, e) with
  | (ID_func i, ET_func tf) =>
    (i < List.length c.(tc_types_t)) &&
    match List.nth_error c.(tc_types_t) i with
    | None => false
    | Some tf' => tf == tf'
    end
  | (ID_table t_t, ET_tab t_t') =>
    (t_t == t_t') && module_tab_typing {| modtab_type := t_t |}
  | (ID_mem mt, ET_mem mt') =>
    (mt == mt') && module_mem_typing mt
  | (ID_global gt, ET_glob gt') => gt == gt'
  | _ => false
  end.

Definition module_export_typing (c : t_context) (d : module_export_desc) (e : extern_t) : bool :=
  match (d, e) with
  | (MED_func (Mk_funcidx i), ET_func tf) =>
    (i < List.length c.(tc_func_t)) &&
    match List.nth_error c.(tc_func_t) i with
    | None => false
    | Some tf' => tf == tf'
    end
  | (MED_table (Mk_tableidx i), ET_tab t_t) =>
    (i < List.length c.(tc_table)) &&
    match List.nth_error c.(tc_table) i with
    | None => false
    | Some lim' => t_t == lim'
    end
  | (MED_mem (Mk_memidx i), ET_mem t_m) =>
    (i < List.length c.(tc_memory)) &&
    match List.nth_error c.(tc_memory) i with
    | None => false
    | Some lim' => t_m == lim' (* TODO: should check for equality of `memory_type`s *)
                            (* UPD: changed a bit *)
    end
  | (MED_global (Mk_globalidx i), ET_glob gt) =>
    (i < List.length c.(tc_global)) &&
    match List.nth_error c.(tc_global) i with
    | None => false
    | Some gt' => gt == gt'
    end
  | (_, _) => false
  end.

Definition pred_option {A} (p : A -> bool) (a_opt : option A) : bool :=
  match a_opt with
  | None => true
  | Some a => p a
  end.

Definition module_typing (m : module) (impts : list extern_t) (expts : list extern_t) : Prop :=
  exists fts gts,
  let '{|
    mod_types := tfs;
    mod_funcs := fs;
    mod_tables := ts;
    mod_mems := ms;
    mod_globals := gs;
    mod_elem := els;
    mod_data := ds;
    mod_start := i_opt;
    mod_imports := imps;
    mod_exports := exps;
  |} := m in
  let ifts := ext_t_funcs impts in
  let its := ext_t_tabs impts in
  let ims := ext_t_mems impts in
  let igs := ext_t_globs impts in
  let c := {|
    tc_types_t := tfs;
    tc_func_t := List.app ifts fts;
    tc_global := List.app igs gts;
    tc_table := List.app its (List.map (fun t => t.(modtab_type)) ts);
    tc_memory := List.app ims ms; (* TODO: should use `mem_type`s *) (* UPD: fixed? *)
    tc_local := nil;
    tc_label := nil;
    tc_return := None;
  |} in
  let c' := {|
    tc_types_t := nil;
    tc_func_t := nil;
    tc_global := igs;
    tc_table := nil;
    tc_memory := nil;
    tc_local := nil;
    tc_label := nil;
    tc_return := None;
  |} in
  List.Forall2 (module_func_typing c) fs fts /\
  seq.all module_tab_typing ts /\
  seq.all module_mem_typing ms /\
  List.Forall2 (module_glob_typing c') gs gts /\
  List.Forall (module_elem_typing c) els /\
  List.Forall (module_data_typing c) ds /\
  pred_option (module_start_typing c) i_opt /\
  List.Forall2 (fun imp => module_import_typing c imp.(imp_desc)) imps impts /\
  List.Forall2 (fun exp => module_export_typing c exp.(modexp_desc)) exps expts.

Inductive external_typing : store_record -> v_ext -> extern_t -> Prop :=
| ETY_func :
  forall (s : store_record) (i : nat) cl (tf : function_type),
  i < List.length s.(s_funcs) ->
  List.nth_error s.(s_funcs) i = Some cl ->
  tf = operations.cl_type cl ->
  external_typing s (MED_func (Mk_funcidx i)) (ET_func tf)
| ETY_tab :
  forall (s : store_record) (i : nat) (ti : tableinst) tt,
  i < List.length s.(s_tables) ->
  List.nth_error s.(s_tables) i = Some ti ->
  typing.tab_typing ti tt ->
  external_typing s (MED_table (Mk_tableidx i)) (ET_tab tt) (* {| tt_limits := lim; tt_elem_type := ELT_funcref |})*)
| ETY_mem :
  forall (s : store_record) (i : nat) (m : memory) (mt : memory_type),
  i < List.length s.(s_mems) ->
  List.nth_error s.(s_mems) i = Some m ->
  typing.mem_typing m mt ->
  external_typing s (MED_mem (Mk_memidx i)) (ET_mem mt)
| ETY_glob :
  forall (s : store_record) (i : nat) (g : global) (gt : global_type),
  i < List.length s.(s_globals) ->
  List.nth_error s.(s_globals) i = Some g ->
  typing.global_agree g gt ->
  external_typing s (MED_global (Mk_globalidx i)) (ET_glob gt).

Definition instantiate_globals inst (hs' : host_state) (s' : store_record) m g_inits : Prop :=
  List.Forall2 (fun g v =>
      opsem.reduce_trans (hs', s', (Build_frame nil inst), operations.to_e_list g.(modglob_init))
                         (hs', s', (Build_frame nil inst), [::AI_basic (BI_const v)]))
    m.(mod_globals) g_inits.

Definition instantiate_elem inst (hs' : host_state) (s' : store_record) m e_offs : Prop :=
  List.Forall2 (fun e c =>
      opsem.reduce_trans (hs', s', (Build_frame nil inst), operations.to_e_list e.(modelem_offset))
                         (hs', s', (Build_frame nil inst), [::AI_basic (BI_const (VAL_int32 c))]))
    m.(mod_elem)
    e_offs.

Definition instantiate_data inst (hs' : host_state) (s' : store_record) m d_offs : Prop :=
  List.Forall2 (fun d c =>
      opsem.reduce_trans (hs', s', (Build_frame nil inst), operations.to_e_list d.(moddata_offset))
                         (hs', s', (Build_frame nil inst), [::AI_basic (BI_const (VAL_int32 c))]))
    m.(mod_data)
    d_offs.

Definition nat_of_int (i : i32) : nat :=
  BinInt.Z.to_nat i.(Wasm_int.Int32.intval).

Definition N_of_int (i : i32) : N :=
  BinInt.Z.to_N i.(Wasm_int.Int32.intval).

Definition check_bounds_elem (inst : instance) (s : store_record) (m : module) (e_offs : seq i32) : bool :=
  seq.all2
    (fun e_off e =>
      match List.nth_error inst.(inst_tab) (match e.(modelem_table) with Mk_tableidx i => i end) with
      | None => false
      | Some i =>
        match List.nth_error s.(s_tables) i with
        | None => false
        | Some ti =>
          N.leb (N.add (N_of_int e_off) (N.of_nat (List.length e.(modelem_init)))) (N.of_nat (List.length ti.(table_data)))
        end
      end)
      e_offs
      m.(mod_elem).

Definition mem_length (m : memory) : N :=
  mem_length m.(mem_data).

Definition check_bounds_data (inst : instance) (s : store_record) (m : module) (d_offs : seq i32) : bool :=
  seq.all2
    (fun d_off d =>
      match List.nth_error inst.(inst_memory) (match d.(moddata_data) with Mk_memidx i => i end) with
      | None => false
      | Some i =>
        match List.nth_error s.(s_mems) i with
        | None => false
        | Some mem =>
          N.leb (N.add (N_of_int d_off) (N.of_nat (List.length d.(moddata_init)))) (mem_length mem)
        end
      end)
      d_offs
      m.(mod_data).

Definition check_start m inst start : bool :=
  let start' :=
    operations.option_bind
    (fun i_s =>
      List.nth_error inst.(inst_funcs) (match i_s.(modstart_func) with Mk_funcidx i => i end))
    m.(mod_start) in
  start' == start.

Definition instantiate (* FIXME: Do we need to use this: [(hs : host_state)] ? *)
                       (s : store_record) (m : module) (v_imps : list v_ext)
                       (z : (store_record * instance * list module_export) * option nat) : Prop :=
  let '((s_end, inst, v_exps), start) := z in
  exists t_imps t_exps hs' s' g_inits e_offs d_offs,
    module_typing m t_imps t_exps /\
    List.Forall2 (external_typing s) v_imps t_imps /\
    alloc_module s m v_imps g_inits (s', inst, v_exps) /\
    instantiate_globals inst hs' s' m g_inits /\
    instantiate_elem inst hs' s' m e_offs /\
    instantiate_data inst hs' s' m d_offs /\
    check_bounds_elem inst s' m e_offs /\
    check_bounds_data inst s' m d_offs /\
    check_start m inst start /\
    let s'' := init_tabs s' inst (map (fun o => BinInt.Z.to_nat o.(Wasm_int.Int32.intval)) e_offs) m.(mod_elem) in
    (s_end : store_record_eqType)
      == init_mems s'' inst (map (fun o => BinInt.Z.to_N o.(Wasm_int.Int32.intval)) d_offs) m.(mod_data).

Definition gather_m_f_type (tfs : list function_type) (m_f : module_func) : option function_type :=
  let '(Mk_typeidx i) := m_f.(modfunc_type) in
  if i < List.length tfs then List.nth_error tfs i
  else None.

Definition gather_m_f_types (tfs : list function_type) (m_fs : list module_func) : option (list function_type) :=
  list_extra.those (List.map (gather_m_f_type tfs) m_fs).

Definition module_import_typer (tfs : list function_type) (imp : import_desc) : option extern_t :=
  match imp with
  | ID_func i =>
    if i < List.length tfs then
      match List.nth_error tfs i with
      | None => None
      | Some ft => Some (ET_func ft)
      end
    else None
  | ID_table t_t =>
    if module_tab_typing {| modtab_type := t_t |} then Some (ET_tab t_t) else None
  | ID_mem mt =>
    if module_mem_typing mt then Some (ET_mem mt) else None
  | ID_global gt => Some (ET_glob gt)
  end.

Definition module_imports_typer (tfs : list function_type) (imps : list module_import) : option (list extern_t) :=
  those (List.map (fun imp => module_import_typer tfs imp.(imp_desc)) imps).

Definition module_export_typer (c : t_context) (exp : module_export_desc) : option extern_t :=
  match exp with
  | MED_func (Mk_funcidx i) =>
    if i < List.length c.(tc_func_t) then
      match List.nth_error c.(tc_func_t) i with
      | None => None
      | Some ft => Some (ET_func ft)
      end
    else None
  | MED_table (Mk_tableidx i) =>
    if i < List.length c.(tc_table) then
      match List.nth_error c.(tc_table) i with
      | None => None
      | Some t_t => Some (ET_tab t_t)
      end
    else None
  | MED_mem (Mk_memidx i) =>
    if i < List.length c.(tc_memory) then
      match List.nth_error c.(tc_memory) i with
      | None => None
      | Some lim => Some (ET_mem lim)
      end
    else None
  | MED_global (Mk_globalidx i) =>
    if i < List.length c.(tc_global) then
      match List.nth_error c.(tc_global) i with
      | None => None
      | Some g => Some (ET_glob g)
      end
    else None
  end.

Definition module_exports_typer (c : t_context) exps :=
  those (List.map (fun exp => module_export_typer c exp.(modexp_desc)) exps).

Definition gather_m_g_types (mgs : list module_glob) : list global_type :=
  List.map (fun mg => mg.(modglob_type)) mgs.

Definition module_func_type_checker (c : t_context) (m : module_func) : bool :=
  let '{| modfunc_type := Mk_typeidx i; modfunc_locals := t_locs; modfunc_body := b_es |} := m in
  (i < List.length c.(tc_types_t)) &&
  match List.nth_error c.(tc_types_t) i with
  | None => false
  | Some (Tf tn tm) =>
    let c' := {|
      tc_types_t := c.(tc_types_t);
      tc_func_t := c.(tc_func_t);
      tc_global := c.(tc_global);
      tc_table := c.(tc_table);
      tc_memory := c.(tc_memory);
      tc_local := List.app c.(tc_local) (List.app tn t_locs);
      tc_label := tm :: c.(tc_label);
      tc_return := Some tm;
    |} in
    type_checker.b_e_type_checker c' b_es (Tf [::] tm)
  end.

Definition module_tab_type_checker := module_tab_typing.
Definition module_memory_type_checker := module_mem_typing.

Definition module_glob_type_checker (c : t_context) (mg : module_glob) : bool :=
  let '{| modglob_type := tg; modglob_init := es |} := mg in
  const_exprs c es &&
  type_checker.b_e_type_checker c es (Tf nil [::tg.(tg_t)]).

Definition module_elem_type_checker (c : t_context) (e : module_element) : bool :=
  let '{| modelem_table := Mk_tableidx t; modelem_offset := es; modelem_init := is_ |} := e in
  const_exprs c es &&
  type_checker.b_e_type_checker c es (Tf nil [::T_i32]) &&
  (t < List.length c.(tc_table)) &&
  seq.all (fun '(Mk_funcidx i) => i < List.length c.(tc_func_t)) is_.

Definition module_data_type_checker (c : t_context) (d : module_data) : bool :=
  let '{| moddata_data := Mk_memidx d; moddata_offset := es; moddata_init := bs |} := d in
  const_exprs c es &&
  type_checker.b_e_type_checker c es (Tf nil [::T_i32]) &&
  (d < List.length c.(tc_memory)).

Definition module_start_type_checker (c : t_context) (ms : module_start) : bool :=
  module_start_typing c ms.

Definition module_type_checker (m : module) : option ((list extern_t) * (list extern_t)) :=
  let '{|
    mod_types := tfs;
    mod_funcs := fs;
    mod_tables := ts;
    mod_mems := ms;
    mod_globals := gs;
    mod_elem := els;
    mod_data := ds;
    mod_start := i_opt;
    mod_imports := imps;
    mod_exports := exps;
    |} := m in
  match (gather_m_f_types tfs fs, module_imports_typer tfs imps) with
  | (Some fts, Some impts) =>
    let ifts := ext_t_funcs impts in
    let its := ext_t_tabs impts in
    let ims := ext_t_mems impts in
    let igs := ext_t_globs impts in
    let gts := gather_m_g_types gs in
    let c := {|
      tc_types_t := tfs;
      tc_func_t := List.app ifts fts;
      tc_global := List.app igs gts;
      tc_table := List.app its (List.map (fun t => t.(modtab_type)) ts);
      tc_memory := List.app ims ms;
      tc_local := nil;
      tc_label := nil;
      tc_return := None |} in
    let c' := {|
      tc_types_t := nil;
      tc_func_t := nil;
      tc_global := igs;
      tc_table := nil;
      tc_memory := nil;
      tc_local := nil;
      tc_label := nil;
      tc_return := None
    |} in
    if seq.all (module_func_type_checker c) fs &&
       seq.all module_tab_type_checker ts &&
       seq.all module_memory_type_checker ms &&
       seq.all (module_glob_type_checker c') gs &&
       seq.all (module_elem_type_checker c) els &&
       seq.all (module_data_type_checker c) ds &&
       pred_option (module_start_type_checker c) i_opt then
       match module_exports_typer c exps with
       | Some expts => Some (impts, expts)
       | None => None
       end
    else None
  | (Some _, None) | (None, Some _) | (None, None) => None
  end.

Definition external_type_checker (s : store_record) (v : v_ext) (e : extern_t) : bool :=
  match (v, e) with
  | (MED_func (Mk_funcidx i), ET_func tf) =>
    (i < List.length s.(s_funcs)) &&
    match List.nth_error s.(s_funcs) i with
    | None => false
    | Some cl => tf == operations.cl_type cl
    end
  | (MED_table (Mk_tableidx i), ET_tab tf) =>
(* TODO   let '{| tt_limits := lim; tt_elem_type := elem_type_tt |} := tf in*)
    (i < List.length s.(s_tables)) &&
    match List.nth_error s.(s_tables) i with
    | None => false
    | Some ti => typing.tab_typing ti tf
    end
  | (MED_mem (Mk_memidx i), ET_mem mt) =>
    (i < List.length s.(s_mems)) &&
    match List.nth_error s.(s_mems) i with
    | None => false
    | Some m => typing.mem_typing m mt
    end
  | (MED_global (Mk_globalidx i), ET_glob gt) =>
    (i < List.length s.(s_globals)) &&
    match List.nth_error s.(s_globals) i with
    | None => false
    | Some g => typing.global_agree g gt
    end
  | (_, _) => false
  end.

Import ITree ITreeFacts.

Import Monads.
Import MonadNotation.

(** The following type is returned as an event when the instantiation failed. **)
Inductive instantiation_error (T : Type) : Type :=
  | Instantiation_error : instantiation_error T.

Arguments Instantiation_error {T}.

Definition interp_get_v (s : store_record) (inst : instance) (b_es : list basic_instruction)
  : itree (instantiation_error +' eff) value (* FIXME: isa mismatch *) :=
  res <- burn 2 (run_v 0 inst (s, (Build_frame nil inst), operations.to_e_list b_es)) ;;
  match res with
  | (_, interpreter.R_value vs) =>
    match vs with
    | v :: nil => ret v
    | _ => trigger_inl1 Instantiation_error
    end
  | _ => trigger_inl1 Instantiation_error
  end.

Definition interp_get_i32 (s : store_record) (inst : instance) (b_es : list basic_instruction)
  : itree (instantiation_error +' eff) i32 (* FIXME: isa mismatch *) :=
  v <- interp_get_v s inst b_es ;;
  match v with
  | VAL_int32 c => ret c
  | _ => trigger_inl1 Instantiation_error
  end.

Definition interp_instantiate (s : store_record) (m : module) (v_imps : list v_ext)
  : itree (instantiation_error +' eff) ((store_record * instance * list module_export) * option nat) :=
  match module_type_checker m with
  | None => trigger_inl1 Instantiation_error
  | Some (t_imps, t_exps) =>
    if seq.all2 (external_type_checker s) v_imps t_imps then
      let inst_c := {|
            inst_types := nil;
            inst_funcs := nil;
            inst_tab := nil;
            inst_memory := nil;
            inst_globs := List.map (fun '(Mk_globalidx i) => i) (ext_globs v_imps);
          |} in
      g_inits <- bind_list (fun g => interp_get_v s inst_c g.(modglob_init)) m.(mod_globals) ;;
      let '(s', inst, v_exps) := interp_alloc_module s m v_imps g_inits in
      e_offs <- bind_list (fun e => interp_get_i32 s' inst e.(modelem_offset)) m.(mod_elem) ;;
      d_offs <- bind_list (fun d => interp_get_i32 s' inst d.(moddata_offset)) m.(mod_data) ;;
      if check_bounds_elem inst s' m e_offs &&
         check_bounds_data inst s' m d_offs then
        let start : option nat := operations.option_bind (fun i_s => List.nth_error inst.(inst_funcs) (match i_s.(modstart_func) with Mk_funcidx i => i end)) m.(mod_start) in
        let s'' := init_tabs s' inst (List.map nat_of_int e_offs) m.(mod_elem) in
        let s_end := init_mems s' inst (List.map N_of_int d_offs) m.(mod_data) in
        ret ((s_end, inst, v_exps), start)
      else trigger_inl1 Instantiation_error
    else trigger_inl1 Instantiation_error
  end.

Lemma interp_instantiate_imp_instantiate :
  forall s m v_imps s_end inst v_exps start,
  interp_instantiate s m v_imps ≈ ret ((s_end, inst, v_exps), start) ->
  instantiate s m v_imps ((s_end, inst, v_exps), start).
Proof.
Admitted. (* TODO *)

Definition empty_store_record : store_record := {|
    s_funcs := nil;
    s_tables := nil;
    s_mems := nil;
    s_globals := nil;
  |}.

Definition interp_instantiate_wrapper (m : module)
  : itree _ ((store_record * instance * list module_export) * option nat) :=
  interp_instantiate empty_store_record m nil.

Definition lookup_exported_function (n : name) (store_inst_exps : store_record * instance * list module_export)
    : option (config_tuple host_function) :=
  let '(s, inst, exps) := store_inst_exps in
  List.fold_left
    (fun acc e =>
      match acc with
      | Some cfg => Some cfg
      | None =>
        if e.(modexp_name) == n then
          match e.(modexp_desc) with
          | MED_func (Mk_funcidx fi) =>
(*            Some (s, (Build_frame nil inst), [::AI_invoke fi])*)
            match List.nth_error s.(s_funcs) fi with
            | None => None
            | Some fc => Some (s, (Build_frame nil inst), [::AI_invoke fi])
            end
          | _ => None
          end
        else None
      end)
    exps
    None.

End Host.

(** As-is, [eqType] tends not to extract well.
  This section provides alternative definitions for better extraction. **)
Module Instantiation (EH : Executable_Host).

Module Exec := convert_to_executable_host EH.
Import Exec.

Definition lookup_exported_function :
    name -> store_record * instance * seq module_export ->
    option config_tuple :=
  @lookup_exported_function _.

Definition interp_instantiate_wrapper :
  module ->
  itree (instantiation_error +' host_event)
    (store_record * instance * seq module_export * option nat) :=
  @interp_instantiate_wrapper _ executable_host_instance _ (fun T e => e).

End Instantiation.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import List.
Require Import ZArith.
Require Import EquivDec.
Require Import RelationClasses.
Require Import Equivalence.
Require Import String.
Require Import Utils.
Require Import DataSystem.
Require Import ForeignReduceOps.
Require Import ForeignToReduceOps.

Require Import EnhancedData.
Require Import EnhancedReduceOps.

Import ListNotations.
Local Open Scope list_scope.
Local Open Scope string_scope.
Local Open Scope nstring_scope.

Definition enhanced_to_reduce_op (uop:unary_op) : option NNRCMR.reduce_op :=
  match uop with
  | OpCount => Some (NNRCMR.RedOpForeign RedOpCount)
  | OpNatSum =>
    Some (NNRCMR.RedOpForeign (RedOpSum enhanced_numeric_int))
  | OpFloatSum =>
    Some (NNRCMR.RedOpForeign (RedOpSum enhanced_numeric_float))
  | OpNatMin =>
    Some (NNRCMR.RedOpForeign (RedOpMin enhanced_numeric_int))
  | OpFloatBagMin =>
    Some (NNRCMR.RedOpForeign (RedOpMin enhanced_numeric_float))
  | OpNatMax =>
    Some (NNRCMR.RedOpForeign (RedOpMax enhanced_numeric_int))
  | OpFloatBagMax =>
    Some (NNRCMR.RedOpForeign (RedOpMax enhanced_numeric_float))
  | OpNatMean =>
    Some (NNRCMR.RedOpForeign (RedOpArithMean enhanced_numeric_int))
  | OpFloatMean =>
    Some (NNRCMR.RedOpForeign (RedOpArithMean enhanced_numeric_float))
  | _ => None
  end.

Definition enhanced_of_reduce_op (rop:NNRCMR.reduce_op) : option unary_op :=
  match rop with
  | NNRCMR.RedOpForeign RedOpCount => Some OpCount
  | NNRCMR.RedOpForeign (RedOpSum enhanced_numeric_int) =>
    Some (OpNatSum)
  | NNRCMR.RedOpForeign (RedOpSum enhanced_numeric_float) =>
    Some (OpFloatSum)
  | NNRCMR.RedOpForeign (RedOpMin enhanced_numeric_int) =>
    Some (OpNatMin)
  | NNRCMR.RedOpForeign (RedOpMin enhanced_numeric_float) =>
    Some (OpFloatBagMin)
  | NNRCMR.RedOpForeign (RedOpMax enhanced_numeric_int) =>
    Some (OpNatMax)
  | NNRCMR.RedOpForeign (RedOpMax enhanced_numeric_float) =>
    Some (OpFloatBagMax)
  | NNRCMR.RedOpForeign (RedOpArithMean enhanced_numeric_int) =>
    Some (OpNatMean)
  | NNRCMR.RedOpForeign (RedOpArithMean enhanced_numeric_float) =>
    Some (OpFloatMean)
  | NNRCMR.RedOpForeign (RedOpStats _) =>
    None (* XXX TODO? XXX *)
  end.

Program Instance enhanced_foreign_to_reduce_op : foreign_to_reduce_op :=
  mk_foreign_to_reduce_op enhanced_foreign_runtime enhanced_foreign_reduce_op enhanced_to_reduce_op _ enhanced_of_reduce_op _.
Next Obligation.
  unfold NNRCMR.reduce_op_eval.
  destruct uop; simpl in *; invcs H; try reflexivity.
Qed.
Next Obligation.
  unfold NNRCMR.reduce_op_eval.
  destruct rop; simpl in *; invcs H; try reflexivity.
  destruct f; invcs H1; simpl; try reflexivity.
  destruct typ; invcs H0; reflexivity.
  destruct typ; invcs H0; reflexivity.
  destruct typ; invcs H0; reflexivity.
  destruct typ; invcs H0; reflexivity.
Qed.