(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for constant propagation. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Events.
Require Import Memory.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import Lattice.
Require Import Kildall.
Require Import ConstpropOp.
Require Import Constprop.
Require Import ConstpropOpproof.

Section PRESERVATION.

Variable prog: program.
Let tprog := transf_program prog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.
Let gapp := make_global_approx (PTree.empty _) prog.(prog_defs).

(** * Correctness of the static analysis *)

Section ANALYSIS.

Variable sp: val.

Definition regs_match_approx (a: D.t) (rs: regset) : Prop :=
  forall r, val_match_approx ge sp (D.get r a) rs#r.

Lemma regs_match_approx_top:
  forall rs, regs_match_approx D.top rs.
Proof.
  intros. red; intros. simpl. rewrite PTree.gempty.
  unfold Approx.top, val_match_approx. auto.
Qed.

Lemma val_match_approx_increasing:
  forall a1 a2 v,
  Approx.ge a1 a2 -> val_match_approx ge sp a2 v -> val_match_approx ge sp a1 v.
Proof.
  intros until v.
  intros [A|[B|C]].
  subst a1. simpl. auto.
  subst a2. simpl. tauto.
  subst a2. auto.
Qed.

Lemma regs_match_approx_increasing:
  forall a1 a2 rs,
  D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs.
Proof.
  unfold D.ge, regs_match_approx. intros.
  apply val_match_approx_increasing with (D.get r a2); auto.
Qed.

Lemma regs_match_approx_update:
  forall ra rs a v r,
  val_match_approx ge sp a v ->
  regs_match_approx ra rs ->
  regs_match_approx (D.set r a ra) (rs#r <- v).
Proof.
  intros; red; intros. rewrite Regmap.gsspec.
  case (peq r0 r); intro.
  subst r0. rewrite D.gss. auto.
  rewrite D.gso; auto.
Qed.

Lemma approx_regs_val_list:
  forall ra rs rl,
  regs_match_approx ra rs ->
  val_list_match_approx ge sp (approx_regs ra rl) rs##rl.
Proof.
  induction rl; simpl; intros.
  constructor.
  constructor. apply H. auto.
Qed.

(** The correctness of the static analysis follows from the results
  of module [ConstpropOpproof] and the fact that the result of
  the static analysis is a solution of the forward dataflow inequations. *)

Lemma analyze_correct_1:
  forall f pc rs pc' i,
  f.(fn_code)!pc = Some i ->
  In pc' (successors_instr i) ->
  regs_match_approx (transfer gapp f pc (analyze gapp f)!!pc) rs ->
  regs_match_approx (analyze gapp f)!!pc' rs.
Proof.
  intros until i. unfold analyze.
  caseEq (DS.fixpoint (successors f) (transfer gapp f)
                      ((fn_entrypoint f, D.top) :: nil)).
  intros approxs; intros.
  apply regs_match_approx_increasing with (transfer gapp f pc approxs!!pc).
  eapply DS.fixpoint_solution; eauto.
  unfold successors_list, successors. rewrite PTree.gmap1. rewrite H0. auto.
  auto.
  intros. rewrite PMap.gi. apply regs_match_approx_top.
Qed.

Lemma analyze_correct_3:
  forall f rs,
  regs_match_approx (analyze gapp f)!!(f.(fn_entrypoint)) rs.
Proof.
  intros. unfold analyze.
  caseEq (DS.fixpoint (successors f) (transfer gapp f)
                      ((fn_entrypoint f, D.top) :: nil)).
  intros approxs; intros.
  apply regs_match_approx_increasing with D.top.
  eapply DS.fixpoint_entry; eauto. auto with coqlib.
  apply regs_match_approx_top.
  intros. rewrite PMap.gi. apply regs_match_approx_top.
Qed.

(** eval_static_load *)

Definition mem_match_approx (m: mem) : Prop :=
  forall id il b,
  gapp!id = Some il -> Genv.find_symbol ge id = Some b ->
  Genv.load_store_init_data ge m b 0 il /\
  Mem.valid_block m b /\
  (forall ofs, ~Mem.perm m b ofs Max Writable).

Lemma eval_load_init_sound:
  forall chunk m b il base ofs pos v,
  Genv.load_store_init_data ge m b base il ->
  Mem.load chunk m b ofs = Some v ->
  ofs = base + pos ->
  val_match_approx ge sp (eval_load_init chunk pos il) v.
Proof.
  induction il; simpl; intros.
(* base case il = nil *)
  auto.
(* inductive case *)
  destruct a.
  (* Init_int8 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  rewrite Mem.load_int8_signed_unsigned in H0. rewrite H in H0. simpl in H0.
  inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_int16 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  rewrite Mem.load_int16_signed_unsigned in H0. rewrite H in H0. simpl in H0.
  inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_int32 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_float32 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_float64 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_space *)
  eapply IHil; eauto. omega.
  (* Init_symbol *)
  destruct H as [[b' [A B]] C].
  destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  unfold symbol_address. rewrite A. congruence.
  eapply IHil; eauto. omega.
Qed.

Lemma eval_static_load_sound:
  forall chunk m addr vaddr v,
  Mem.loadv chunk m vaddr = Some v ->
  mem_match_approx m ->
  val_match_approx ge sp addr vaddr ->
  val_match_approx ge sp (eval_static_load gapp chunk addr) v.
Proof.
  intros. unfold eval_static_load. destruct addr; simpl; auto.
  destruct (gapp!i) as [il|] eqn:?; auto.
  red in H1. subst vaddr. unfold symbol_address in H.
  destruct (Genv.find_symbol ge i) as [b'|] eqn:?; simpl in H; try discriminate.
  exploit H0; eauto. intros [A [B C]].
  eapply eval_load_init_sound; eauto.
  red; auto.
Qed.

Lemma mem_match_approx_store:
  forall chunk m addr v m',
  mem_match_approx m ->
  Mem.storev chunk m addr v = Some m' ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  destruct addr; simpl in H0; try discriminate.
  exploit Mem.store_valid_access_3; eauto. intros [P Q].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply Mem.load_store_other; eauto. left; red; intro; subst b0.
  eapply C. apply Mem.perm_cur_max. eapply P. instantiate (1 := Int.unsigned i).
  generalize (size_chunk_pos chunk). omega.
  split. eauto with mem.
  intros; red; intros. eapply C. eapply Mem.perm_store_2; eauto.
Qed.

Lemma mem_match_approx_alloc:
  forall m lo hi b m',
  mem_match_approx m ->
  Mem.alloc m lo hi = (m', b) ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply Mem.load_alloc_unchanged; eauto.
  split. eauto with mem.
  intros; red; intros. exploit Mem.perm_alloc_inv; eauto.
  rewrite zeq_false. apply C. eapply Mem.valid_not_valid_diff; eauto with mem.
Qed.

Lemma mem_match_approx_free:
  forall m lo hi b m',
  mem_match_approx m ->
  Mem.free m b lo hi = Some m' ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply Mem.load_free; eauto.
  destruct (zeq b0 b); auto. subst b0.
  right. destruct (zlt lo hi); auto.
  elim (C lo). apply Mem.perm_cur_max.
  exploit Mem.free_range_perm; eauto. instantiate (1 := lo); omega.
  intros; eapply Mem.perm_implies; eauto with mem.
  split. eauto with mem.
  intros; red; intros. eapply C. eauto with mem.
Qed.

Lemma mem_match_approx_extcall:
  forall ef vargs m t vres m',
  mem_match_approx m ->
  external_call ef ge vargs m t vres m' ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply external_call_readonly; eauto.
  split. eapply external_call_valid_block; eauto.
  intros; red; intros. elim (C ofs). eapply external_call_max_perm; eauto.
Qed.

(* Show that mem_match_approx holds initially *)

Definition global_approx_charact (g: genv) (ga: global_approx) : Prop :=
  forall id il b,
  ga!id = Some il ->
  Genv.find_symbol g id = Some b ->
  Genv.find_var_info g b = Some (mkglobvar tt il true false).

Lemma make_global_approx_correct:
  forall gdl g ga,
  global_approx_charact g ga ->
  global_approx_charact (Genv.add_globals g gdl) (make_global_approx ga gdl).
Proof.
  induction gdl; simpl; intros.
  auto.
  destruct a as [id gd]. apply IHgdl.
  red; intros.
  assert (EITHER: id0 = id /\ gd = Gvar(mkglobvar tt il true false)
               \/ id0 <> id /\ ga!id0 = Some il).
  destruct gd.
  rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id); [discriminate|auto].
  destruct (gvar_readonly v && negb (gvar_volatile v)) eqn:?.
  rewrite PTree.gsspec in H0. destruct (peq id0 id).
  inv H0. left. split; auto.
  destruct v; simpl in *.
  destruct gvar_readonly; try discriminate.
  destruct gvar_volatile; try discriminate.
  destruct gvar_info. auto.
  auto.
  rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id); [discriminate|auto].

  unfold Genv.add_global, Genv.find_symbol, Genv.find_var_info in *;
  simpl in *.
  destruct EITHER as [[A B] | [A B]].
  subst id0. rewrite PTree.gss in H1. inv H1. rewrite ZMap.gss. auto.
  rewrite PTree.gso in H1; auto. destruct gd. eapply H; eauto.
  rewrite ZMap.gso. eapply H; eauto.
  exploit Genv.genv_symb_range; eauto. unfold ZIndexed.t. omega.
Qed.

Theorem mem_match_approx_init:
  forall m, Genv.init_mem prog = Some m -> mem_match_approx m.
Proof.
  intros.
  assert (global_approx_charact ge gapp).
    unfold ge, gapp.   unfold Genv.globalenv.
    apply make_global_approx_correct.
    red; intros. rewrite PTree.gempty in H0; discriminate.
  red; intros.
  exploit Genv.init_mem_characterization.
  unfold ge in H0. eapply H0; eauto. eauto.
  unfold Genv.perm_globvar; simpl.
  intros [A [B C]].
  split. auto. split. eapply Genv.find_symbol_not_fresh; eauto.
  intros; red; intros. exploit B; eauto. intros [P Q]. inv Q.
Qed.

End ANALYSIS.

(** * Correctness of the code transformation *)

(** We now show that the transformed code after constant propagation
  has the same semantics as the original code. *)

Lemma symbols_preserved:
  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
Proof.
  intros; unfold ge, tge, tprog, transf_program.
  apply Genv.find_symbol_transf.
Qed.

Lemma varinfo_preserved:
  forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
Proof.
  intros; unfold ge, tge, tprog, transf_program.
  apply Genv.find_var_info_transf.
Qed.

Lemma functions_translated:
  forall (v: val) (f: fundef),
  Genv.find_funct ge v = Some f ->
  Genv.find_funct tge v = Some (transf_fundef gapp f).
Proof.
  intros.
  exact (Genv.find_funct_transf (transf_fundef gapp) _ _ H).
Qed.

Lemma function_ptr_translated:
  forall (b: block) (f: fundef),
  Genv.find_funct_ptr ge b = Some f ->
  Genv.find_funct_ptr tge b = Some (transf_fundef gapp f).
Proof.
  intros.
  exact (Genv.find_funct_ptr_transf (transf_fundef gapp) _ _ H).
Qed.

Lemma sig_function_translated:
  forall f,
  funsig (transf_fundef gapp f) = funsig f.
Proof.
  intros. destruct f; reflexivity.
Qed.

Definition regs_lessdef (rs1 rs2: regset) : Prop :=
  forall r, Val.lessdef (rs1#r) (rs2#r).

Lemma regs_lessdef_regs:
  forall rs1 rs2, regs_lessdef rs1 rs2 ->
  forall rl, Val.lessdef_list rs1##rl rs2##rl.
Proof.
  induction rl; constructor; auto.
Qed.

Lemma set_reg_lessdef:
  forall r v1 v2 rs1 rs2,
  Val.lessdef v1 v2 -> regs_lessdef rs1 rs2 -> regs_lessdef (rs1#r <- v1) (rs2#r <- v2).
Proof.
  intros; red; intros. repeat rewrite Regmap.gsspec.
  destruct (peq r0 r); auto.
Qed.

Lemma init_regs_lessdef:
  forall rl vl1 vl2,
  Val.lessdef_list vl1 vl2 ->
  regs_lessdef (init_regs vl1 rl) (init_regs vl2 rl).
Proof.
  induction rl; simpl; intros.
  red; intros. rewrite Regmap.gi. auto.
  inv H. red; intros. rewrite Regmap.gi. auto.
  apply set_reg_lessdef; auto.
Qed.

Lemma transf_ros_correct:
  forall sp ros rs rs' f approx,
  regs_match_approx sp approx rs ->
  find_function ge ros rs = Some f ->
  regs_lessdef rs rs' ->
  find_function tge (transf_ros approx ros) rs' = Some (transf_fundef gapp f).
Proof.
  intros. destruct ros; simpl in *.
  generalize (H r); intro MATCH. generalize (H1 r); intro LD.
  destruct (rs#r); simpl in H0; try discriminate.
  destruct (Int.eq_dec i Int.zero); try discriminate.
  inv LD.
  assert (find_function tge (inl _ r) rs' = Some (transf_fundef gapp f)).
    simpl. rewrite <- H4. simpl. rewrite dec_eq_true. apply function_ptr_translated. auto.
  destruct (D.get r approx); auto.
  predSpec Int.eq Int.eq_spec i0 Int.zero; intros; auto.
  simpl in *. unfold symbol_address in MATCH. rewrite symbols_preserved.
  destruct (Genv.find_symbol ge i); try discriminate.
  inv MATCH. apply function_ptr_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i); try discriminate.
  apply function_ptr_translated; auto.
Qed.

Lemma const_for_result_correct:
  forall a op sp v m,
  const_for_result a = Some op ->
  val_match_approx ge sp a v ->
  eval_operation tge sp op nil m = Some v.
Proof.
  unfold const_for_result; intros.
  destruct a; inv H; simpl in H0.
  simpl. congruence.
  destruct (generate_float_constants tt); inv H2.  simpl. congruence.
  simpl. subst v. unfold symbol_address. rewrite symbols_preserved. auto.
  simpl. congruence.
Qed.

Inductive match_pc (f: function) (app: D.t): nat -> node -> node -> Prop :=
  | match_pc_base: forall n pc,
      match_pc f app n pc pc
  | match_pc_nop: forall n pc s pcx,
      f.(fn_code)!pc = Some (Inop s) ->
      match_pc f app n s pcx ->
      match_pc f app (Datatypes.S n) pc pcx
  | match_pc_cond: forall n pc cond args s1 s2 b,
      f.(fn_code)!pc = Some (Icond cond args s1 s2) ->
      eval_static_condition cond (approx_regs app args) = Some b ->
      match_pc f app (Datatypes.S n) pc (if b then s1 else s2).

Lemma match_successor_rec:
  forall f app n pc, match_pc f app n pc (successor_rec n f app pc).
Proof.
  induction n; simpl; intros.
  apply match_pc_base.
  destruct (fn_code f)!pc as [i|] eqn:?; try apply match_pc_base.
  destruct i; try apply match_pc_base.
  eapply match_pc_nop; eauto.
  destruct (eval_static_condition c (approx_regs app l)) as [b|] eqn:?.
  eapply match_pc_cond; eauto.
  apply match_pc_base.
Qed.

Lemma match_successor:
  forall f app pc, match_pc f app num_iter pc (successor f app pc).
Proof.
  unfold successor; intros. apply match_successor_rec.
Qed.

Section BUILTIN_STRENGTH_REDUCTION.
Variable app: D.t.
Variable sp: val.
Variable rs: regset.
Hypothesis MATCH: forall r, val_match_approx ge sp (approx_reg app r) rs#r.

Lemma annot_strength_reduction_correct:
  forall targs args targs' args' eargs,
  annot_strength_reduction app targs args = (targs', args') ->
  eventval_list_match ge eargs (annot_args_typ targs) rs##args ->
  exists eargs',
  eventval_list_match ge eargs' (annot_args_typ targs') rs##args'
  /\ annot_eventvals targs' eargs' = annot_eventvals targs eargs.
Proof.
  induction targs; simpl; intros.
- inv H. simpl. exists eargs; auto.
- destruct a.
  + destruct args as [ | arg args0]; simpl in H0; inv H0.
    destruct (annot_strength_reduction app targs args0) as [targs'' args''] eqn:E.
    exploit IHtargs; eauto. intros [eargs'' [A B]].
    assert (DFL:
      exists eargs',
      eventval_list_match ge eargs' (annot_args_typ (AA_arg ty :: targs'')) rs##(arg :: args'')
      /\ annot_eventvals (AA_arg ty :: targs'') eargs' = ev1 :: annot_eventvals targs evl).
    {
      exists (ev1 :: eargs''); split.
      simpl; constructor; auto. simpl. congruence.
    }
    destruct ty; destruct (approx_reg app arg) as [] eqn:E2; inv H; auto;
    exists eargs''; split; auto; simpl; f_equal; auto;
    generalize (MATCH arg); rewrite E2; simpl; intros E3;
    rewrite E3 in H5; inv H5; auto.
  + destruct (annot_strength_reduction app targs args) as [targs'' args''] eqn:E.
    inv H.
    exploit IHtargs; eauto. intros [eargs'' [A B]].
    exists eargs''; simpl; split; auto. congruence.
  + destruct (annot_strength_reduction app targs args) as [targs'' args''] eqn:E.
    inv H.
    exploit IHtargs; eauto. intros [eargs'' [A B]].
    exists eargs''; simpl; split; auto. congruence.
Qed.

Lemma builtin_strength_reduction_correct:
  forall ef args m t vres m',
  external_call ef ge rs##args m t vres m' ->
  let (ef', args') := builtin_strength_reduction app ef args in
  external_call ef' ge rs##args' m t vres m'.
Proof.
  intros until m'. functional induction (builtin_strength_reduction app ef args); intros; auto.
+ generalize (MATCH r1); rewrite e1; simpl; intros E. simpl in H.
  unfold symbol_address in E. destruct (Genv.find_symbol ge symb) as [b|] eqn:?; rewrite E in H.
  rewrite volatile_load_global_charact. exists b; auto.
  inv H.
+ generalize (MATCH r1); rewrite e1; simpl; intros E. simpl in H.
  unfold symbol_address in E. destruct (Genv.find_symbol ge symb) as [b|] eqn:?; rewrite E in H.
  rewrite volatile_store_global_charact. exists b; auto.
  inv H.
+ inv H. exploit annot_strength_reduction_correct; eauto.
  intros [eargs' [A B]].
  rewrite <- B. econstructor; eauto.
Qed.

End BUILTIN_STRENGTH_REDUCTION.

(** The proof of semantic preservation is a simulation argument
  based on "option" diagrams of the following form:
<<
                 n
       st1 --------------- st2
        |                   |
       t|                   |t or (? and n' < n)
        |                   |
        v                   v
       st1'--------------- st2'
                 n'
>>
  The left vertical arrow represents a transition in the
  original RTL code.  The top horizontal bar is the [match_states]
  invariant between the initial state [st1] in the original RTL code
  and an initial state [st2] in the transformed code.
  This invariant expresses that all code fragments appearing in [st2]
  are obtained by [transf_code] transformation of the corresponding
  fragments in [st1].  Moreover, the values of registers in [st1]
  must match their compile-time approximations at the current program
  point.
  These two parts of the diagram are the hypotheses.  In conclusions,
  we want to prove the other two parts: the right vertical arrow,
  which is a transition in the transformed RTL code, and the bottom
  horizontal bar, which means that the [match_state] predicate holds
  between the final states [st1'] and [st2']. *)

Inductive match_stackframes: stackframe -> stackframe -> Prop :=
   match_stackframe_intro:
      forall res sp pc rs f rs',
      regs_lessdef rs rs' ->
      (forall v, regs_match_approx sp (analyze gapp f)!!pc (rs#res <- v)) ->
    match_stackframes
        (Stackframe res f sp pc rs)
        (Stackframe res (transf_function gapp f) sp pc rs').

Inductive match_states: nat -> state -> state -> Prop :=
  | match_states_intro:
      forall s sp pc rs m f s' pc' rs' m' app n
           (MATCH1: regs_match_approx sp app rs)
           (MATCH2: regs_match_approx sp (analyze gapp f)!!pc rs)
           (GMATCH: mem_match_approx m)
           (STACKS: list_forall2 match_stackframes s s')
           (PC: match_pc f app n pc pc')
           (REGS: regs_lessdef rs rs')
           (MEM: Mem.extends m m'),
      match_states n (State s f sp pc rs m)
                    (State s' (transf_function gapp f) sp pc' rs' m')
  | match_states_call:
      forall s f args m s' args' m'
           (GMATCH: mem_match_approx m)
           (STACKS: list_forall2 match_stackframes s s')
           (ARGS: Val.lessdef_list args args')
           (MEM: Mem.extends m m'),
      match_states O (Callstate s f args m)
                    (Callstate s' (transf_fundef gapp f) args' m')
  | match_states_return:
      forall s v m s' v' m'
           (GMATCH: mem_match_approx m)
           (STACKS: list_forall2 match_stackframes s s')
           (RES: Val.lessdef v v')
           (MEM: Mem.extends m m'),
      list_forall2 match_stackframes s s' ->
      match_states O (Returnstate s v m)
                    (Returnstate s' v' m').

Lemma match_states_succ:
  forall s f sp pc2 rs m s' rs' m' pc1 i,
  f.(fn_code)!pc1 = Some i ->
  In pc2 (successors_instr i) ->
  regs_match_approx sp (transfer gapp f pc1 (analyze gapp f)!!pc1) rs ->
  mem_match_approx m ->
  list_forall2 match_stackframes s s' ->
  regs_lessdef rs rs' ->
  Mem.extends m m' ->
  match_states O (State s f sp pc2 rs m)
                (State s' (transf_function gapp f) sp pc2 rs' m').
Proof.
  intros.
  assert (regs_match_approx sp (analyze gapp f)!!pc2 rs).
    eapply analyze_correct_1; eauto.
  apply match_states_intro with (app := (analyze gapp f)!!pc2); auto.
  constructor.
Qed.

Lemma transf_instr_at:
  forall f pc i,
  f.(fn_code)!pc = Some i ->
  (transf_function gapp f).(fn_code)!pc = Some(transf_instr gapp f (analyze gapp f) pc i).
Proof.
  intros. simpl. unfold transf_code. rewrite PTree.gmap. rewrite H. auto.
Qed.

Ltac TransfInstr :=
  match goal with
  | H: (PTree.get ?pc (fn_code ?f) = Some ?instr) |- _ =>
      generalize (transf_instr_at _ _ _ H); simpl
  end.

(** The proof of simulation proceeds by case analysis on the transition
  taken in the source code. *)

Lemma transf_step_correct:
  forall s1 t s2,
  step ge s1 t s2 ->
  forall n1 s1' (MS: match_states n1 s1 s1'),
  (exists n2, exists s2', step tge s1' t s2' /\ match_states n2 s2 s2')
  \/ (exists n2, n2 < n1 /\ t = E0 /\ match_states n2 s2 s1')%nat.
Proof.
  induction 1; intros; inv MS; try (inv PC; try congruence).

  (* Inop, preserved *)
  rename pc'0 into pc. TransfInstr; intro.
  left; econstructor; econstructor; split.
  eapply exec_Inop; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. auto.

  (* Inop, skipped over *)
  rewrite H0 in H; inv H.
  right; exists n; split. omega. split. auto.
  apply match_states_intro with app; auto.
  eapply analyze_correct_1; eauto. simpl; auto.
  unfold transfer; rewrite H0. auto.

  (* Iop *)
  rename pc'0 into pc. TransfInstr.
  set (app_before := (analyze gapp f)#pc).
  set (a := eval_static_operation op (approx_regs app_before args)).
  set (app_after := D.set res a app_before).
  assert (VMATCH: val_match_approx ge sp a v).
    eapply eval_static_operation_correct; eauto.
    apply approx_regs_val_list; auto.
  assert (MATCH': regs_match_approx sp app_after rs#res <- v).
    apply regs_match_approx_update; auto.
  assert (MATCH'': regs_match_approx sp (analyze gapp f) # pc' rs # res <- v).
    eapply analyze_correct_1 with (pc := pc); eauto. simpl; auto.
    unfold transfer; rewrite H. auto.
  destruct (const_for_result a) as [cop|] eqn:?; intros.
  (* constant is propagated *)
  left; econstructor; econstructor; split.
  eapply exec_Iop; eauto.
  eapply const_for_result_correct; eauto.
  apply match_states_intro with app_after; auto.
  apply match_successor.
  apply set_reg_lessdef; auto.
  (* operator is strength-reduced *)
  exploit op_strength_reduction_correct. eexact MATCH2. reflexivity. eauto.
  fold app_before.
  destruct (op_strength_reduction op args (approx_regs app_before args)) as [op' args'].
  intros [v' [EV' LD']].
  assert (EV'': exists v'', eval_operation ge sp op' rs'##args' m' = Some v'' /\ Val.lessdef v' v'').
  eapply eval_operation_lessdef; eauto. eapply regs_lessdef_regs; eauto.
  destruct EV'' as [v'' [EV'' LD'']].
  left; econstructor; econstructor; split.
  eapply exec_Iop; eauto.
  erewrite eval_operation_preserved. eexact EV''. exact symbols_preserved.
  apply match_states_intro with app_after; auto.
  apply match_successor.
  apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto.

  (* Iload *)
  rename pc'0 into pc. TransfInstr.
  set (ap1 := eval_static_addressing addr
               (approx_regs (analyze gapp f) # pc args)).
  set (ap2 := eval_static_load gapp chunk ap1).
  assert (VM1: val_match_approx ge sp ap1 a).
    eapply eval_static_addressing_correct; eauto.
    eapply approx_regs_val_list; eauto.
  assert (VM2: val_match_approx ge sp ap2 v).
    eapply eval_static_load_sound; eauto.
  destruct (const_for_result ap2) as [cop|] eqn:?; intros.
  (* constant-propagated *)
  left; econstructor; econstructor; split.
  eapply exec_Iop; eauto. eapply const_for_result_correct; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. apply regs_match_approx_update; auto.
  apply set_reg_lessdef; auto.
  (* strength-reduced *)
  generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs
                  MATCH2 addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
  destruct (addr_strength_reduction addr args (approx_regs (analyze gapp f) # pc args)) as [addr' args'].
  rewrite H0. intros P.
  assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a').
    eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto.
  destruct ADDR' as [a' [A B]].
  assert (C: eval_addressing tge sp addr' rs'##args' = Some a').
    rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved.
  exploit Mem.loadv_extends; eauto. intros [v' [D E]].
  left; econstructor; econstructor; split.
  eapply exec_Iload; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. apply regs_match_approx_update; auto.
  apply set_reg_lessdef; auto.

  (* Istore *)
  rename pc'0 into pc. TransfInstr.
  generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs
                  MATCH2 addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
  destruct (addr_strength_reduction addr args (approx_regs (analyze gapp f) # pc args)) as [addr' args'].
  intros P Q. rewrite H0 in P.
  assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a').
    eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto.
  destruct ADDR' as [a' [A B]].
  assert (C: eval_addressing tge sp addr' rs'##args' = Some a').
    rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved.
  exploit Mem.storev_extends; eauto. intros [m2' [D E]].
  left; econstructor; econstructor; split.
  eapply exec_Istore; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. auto.
  eapply mem_match_approx_store; eauto.

  (* Icall *)
  rename pc'0 into pc.
  exploit transf_ros_correct; eauto. intro FIND'.
  TransfInstr; intro.
  left; econstructor; econstructor; split.
  eapply exec_Icall; eauto. apply sig_function_translated; auto.
  constructor; auto. constructor; auto.
  econstructor; eauto.
  intros. eapply analyze_correct_1; eauto. simpl; auto.
  unfold transfer; rewrite H.
  apply regs_match_approx_update; auto. simpl. auto.
  apply regs_lessdef_regs; auto.

  (* Itailcall *)
  exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]].
  exploit transf_ros_correct; eauto. intros FIND'.
  TransfInstr; intro.
  left; econstructor; econstructor; split.
  eapply exec_Itailcall; eauto. apply sig_function_translated; auto.
  constructor; auto.
  eapply mem_match_approx_free; eauto.
  apply regs_lessdef_regs; auto.

  (* Ibuiltin *)
  rename pc'0 into pc.
Opaque builtin_strength_reduction.
  exploit builtin_strength_reduction_correct; eauto.
  TransfInstr.
  destruct (builtin_strength_reduction (analyze gapp f)#pc ef args) as [ef' args'].
  intros P Q.
  exploit external_call_mem_extends; eauto.
  instantiate (1 := rs'##args'). apply regs_lessdef_regs; auto.
  intros [v' [m2' [A [B [C D]]]]].
  left; econstructor; econstructor; split.
  eapply exec_Ibuiltin. eauto.
  eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H.
  apply regs_match_approx_update; auto. simpl; auto.
  eapply mem_match_approx_extcall; eauto.
  apply set_reg_lessdef; auto.

  (* Icond, preserved *)
  rename pc'0 into pc. TransfInstr.
  generalize (cond_strength_reduction_correct ge sp (analyze gapp f)#pc rs m
                    MATCH2 cond args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
  destruct (cond_strength_reduction cond args (approx_regs (analyze gapp f) # pc args)) as [cond' args'].
  intros EV1 TCODE.
  left; exists O; exists (State s' (transf_function gapp f) sp (if b then ifso else ifnot) rs' m'); split.
  destruct (eval_static_condition cond (approx_regs (analyze gapp f) # pc args)) eqn:?.
  assert (eval_condition cond rs ## args m = Some b0).
    eapply eval_static_condition_correct; eauto. eapply approx_regs_val_list; eauto.
  assert (b = b0) by congruence. subst b0.
  destruct b; eapply exec_Inop; eauto.
  eapply exec_Icond; eauto.
  eapply eval_condition_lessdef with (vl1 := rs##args'); eauto. eapply regs_lessdef_regs; eauto. congruence.
  eapply match_states_succ; eauto.
  destruct b; simpl; auto.
  unfold transfer; rewrite H. auto.

  (* Icond, skipped over *)
  rewrite H1 in H; inv H.
  assert (eval_condition cond rs ## args m = Some b0).
    eapply eval_static_condition_correct; eauto. eapply approx_regs_val_list; eauto.
  assert (b = b0) by congruence. subst b0.
  right; exists n; split. omega. split. auto.
  assert (MATCH': regs_match_approx sp (analyze gapp f) # (if b then ifso else ifnot) rs).
    eapply analyze_correct_1; eauto. destruct b; simpl; auto.
    unfold transfer; rewrite H1; auto.
  econstructor; eauto. constructor.

  (* Ijumptable *)
  rename pc'0 into pc.
  assert (A: (fn_code (transf_function gapp f))!pc = Some(Ijumptable arg tbl)
             \/ (fn_code (transf_function gapp f))!pc = Some(Inop pc')).
  TransfInstr. destruct (approx_reg (analyze gapp f) # pc arg) eqn:?; auto.
  generalize (MATCH2 arg). unfold approx_reg in Heqt. rewrite Heqt. rewrite H0.
  simpl. intro EQ; inv EQ. rewrite H1. auto.
  assert (B: rs'#arg = Vint n).
  generalize (REGS arg); intro LD; inv LD; congruence.
  left; exists O; exists (State s' (transf_function gapp f) sp pc' rs' m'); split.
  destruct A. eapply exec_Ijumptable; eauto. eapply exec_Inop; eauto.
  eapply match_states_succ; eauto.
  simpl. eapply list_nth_z_in; eauto.
  unfold transfer; rewrite  H; auto.

  (* Ireturn *)
  exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]].
  left; exists O; exists (Returnstate s' (regmap_optget or Vundef rs') m2'); split.
  eapply exec_Ireturn; eauto. TransfInstr; auto.
  constructor; auto.
  eapply mem_match_approx_free; eauto.
  destruct or; simpl; auto.

  (* internal function *)
  exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl.
  intros [m2' [A B]].
  simpl. unfold transf_function.
  left; exists O; econstructor; split.
  eapply exec_function_internal; simpl; eauto.
  simpl. econstructor; eauto.
  apply analyze_correct_3; auto.
  apply analyze_correct_3; auto.
  eapply mem_match_approx_alloc; eauto.
  instantiate (1 := f). constructor.
  apply init_regs_lessdef; auto.

  (* external function *)
  exploit external_call_mem_extends; eauto.
  intros [v' [m2' [A [B [C D]]]]].
  simpl. left; econstructor; econstructor; split.
  eapply exec_function_external; eauto.
  eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  constructor; auto.
  eapply mem_match_approx_extcall; eauto.

  (* return *)
  inv H4. inv H1.
  left; exists O; econstructor; split.
  eapply exec_return; eauto.
  econstructor; eauto. constructor. apply set_reg_lessdef; auto.
Qed.

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists n, exists st2, initial_state tprog st2 /\ match_states n st1 st2.
Proof.
  intros. inversion H.
  exploit function_ptr_translated; eauto. intro FIND.
  exists O; exists (Callstate nil (transf_fundef gapp f) nil m0); split.
  econstructor; eauto.
  apply Genv.init_mem_transf; auto.
  replace (prog_main tprog) with (prog_main prog).
  rewrite symbols_preserved. eauto.
  reflexivity.
  rewrite <- H3. apply sig_function_translated.
  constructor.
  eapply mem_match_approx_init; eauto.
  constructor. constructor. apply Mem.extends_refl.
Qed.

Lemma transf_final_states:
  forall n st1 st2 r,
  match_states n st1 st2 -> final_state st1 r -> final_state st2 r.
Proof.
  intros. inv H0. inv H. inv STACKS. inv RES. constructor.
Qed.

(** The preservation of the observable behavior of the program then
  follows. *)

Theorem transf_program_correct:
  forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
Proof.
  eapply Forward_simulation with (fsim_order := lt); simpl.
  apply lt_wf.
  eexact transf_initial_states.
  eexact transf_final_states.
  fold ge; fold tge. intros.
    exploit transf_step_correct; eauto.
    intros [ [n2 [s2' [A B]]] | [n2 [A [B C]]]].
    exists n2; exists s2'; split; auto. left; apply plus_one; auto.
    exists n2; exists s2; split; auto. right; split; auto. subst t; apply star_refl.
  eexact symbols_preserved.
Qed.

End PRESERVATION.


Require A.

Definition c := A.b.
Lemma foo : c = false.
Proof.
reflexivity.
Qed.


Require Import floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.sha_lemmas.
Require Import sha.bdo_lemmas.
Require Import sha.spec_sha.
Local Open Scope logic.

Lemma sha256_block_data_order_return:
   forall (Espec : OracleKind) (hashed b : list int) (ctx data : val)
            (sh : share) (regs : registers) kv,
  Zlength b = LBLOCKz ->
  (LBLOCKz | Zlength hashed) ->
  regs = hash_blocks init_registers hashed ->
  semax (initialized _t Delta_loop1)
  (PROP  ()
   LOCAL  (`(eq ctx) (eval_id _ctx);
                `(eq kv) (eval_var _K256 (tarray tuint CBLOCKz)))
   SEP
   (`(array_at tuint Tsh (tuints (hash_block regs b)) 0 8 ctx);
    `(K_vector kv);
   `(array_at_ tuint Tsh 0 LBLOCKz) (eval_var _X (tarray tuint LBLOCKz));
   `(data_block sh (intlist_to_Zlist b) data)))
  (Sreturn None)
  (frame_ret_assert
     (function_body_ret_assert tvoid
        (`(array_at tuint Tsh
             (tuints (hash_blocks init_registers (hashed ++ b))) 0 8 ctx) *
         `(data_block sh (intlist_to_Zlist b) data) *
         `(K_vector kv)))
     (stackframe_of f_sha256_block_data_order)).
Proof.
intros.
unfold Delta_loop1; simplify_Delta.
forward. (* return; *)
unfold frame_ret_assert; simpl.
unfold sha256state_.
set (regs := hash_block (hash_blocks init_registers hashed) b).
unfold_lift.
simpl_stackframe_of.
unfold data_at_.
unfold tarray.
erewrite data_at_array_at; [| reflexivity | omega | reflexivity].
unfold id.
entailer!.
apply derives_refl'; f_equal.
f_equal.
unfold regs.
apply hash_blocks_last; auto.
Qed.


From iris.program_logic Require Export weakestpre.
From iris.program_logic Require Import ectx_lifting.
From iris_logrel.F_mu Require Export lang.
From iris.prelude Require Import fin_maps.

Section lang_rules.
  Context `{irisG lang Σ}.
  Implicit Types P : iProp Σ.
  Implicit Types Φ : val → iProp Σ.

  Ltac inv_head_step :=
    repeat match goal with
    | _ => progress simplify_map_eq/= (* simplify memory stuff *)
    | H : to_val _ = Some _ |- _ => apply of_to_val in H
    | H : head_step ?e _ _ _ _ |- _ =>
       try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable
       and can thus better be avoided. *)
       inversion H; subst; clear H
    end.

  Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl.

  Local Hint Constructors head_step.
  Local Hint Resolve to_of_val.

  (** Helper Lemmas for weakestpre. *)

  Lemma wp_bind {E e} K Φ :
    WP e @ E {{ v, WP fill K (# v) @ E {{ Φ }} }} ⊢ WP fill K e @ E {{ Φ }}.
  Proof. exact: wp_ectx_bind. Qed.

  Lemma wp_lam E e1 e2 v Φ :
    to_val e2 = Some v → ▷ WP e1.[e2 /] @ E {{ Φ }} ⊢ WP App (Lam e1) e2 @ E {{ Φ }}.
  Proof.
    intros <-%of_to_val.
    rewrite -(wp_lift_pure_det_head_step' (App _ _) e1.[of_val v /]); eauto.
    intros; inv_head_step; eauto.
  Qed.

  Lemma wp_tlam E e Φ : ▷ WP e @ E {{ Φ }} ⊢ WP TApp (TLam e) @ E {{ Φ }}.
  Proof.
    rewrite -(wp_lift_pure_det_head_step' (TApp _) e); eauto.
    intros; inv_head_step; eauto.
  Qed.

  Lemma wp_fold E e v Φ :
    to_val e = Some v → ▷ (|={E}=> Φ v) ⊢ WP Unfold (Fold e) @ E {{ Φ }}.
  Proof.
    intros <-%of_to_val.
    rewrite -(wp_lift_pure_det_head_step' (Unfold _) (of_val v))
      -?wp_value_fupd; eauto.
    intros; inv_head_step; eauto.
  Qed.

  Lemma wp_fst E e1 v1 e2 v2 Φ :
    to_val e1 = Some v1 → to_val e2 = Some v2 →
    ▷ (|={E}=> Φ v1) ⊢ WP Fst (Pair e1 e2) @ E {{ Φ }}.
  Proof.
    intros ??. rewrite -(wp_lift_pure_det_head_step' (Fst _) e1)
      -?wp_value_fupd; eauto.
    intros; inv_head_step; eauto.
  Qed.

  Lemma wp_snd E e1 v1 e2 v2 Φ :
    to_val e1 = Some v1 → to_val e2 = Some v2 →
    ▷ (|={E}=> Φ v2) ⊢ WP Snd (Pair e1 e2) @ E {{ Φ }}.
  Proof.
    intros ??. rewrite -(wp_lift_pure_det_head_step' (Snd _) e2)
      -?wp_value_fupd; eauto.
    intros; inv_head_step; eauto.
  Qed.

  Lemma wp_case_inl E e0 v0 e1 e2 Φ :
    to_val e0 = Some v0 →
    ▷ WP e1.[e0/] @ E {{ Φ }} ⊢ WP Case (InjL e0) e1 e2 @ E {{ Φ }}.
  Proof.
    intros. rewrite -(wp_lift_pure_det_head_step' (Case _ _ _) (e1.[e0/])); eauto.
    intros; inv_head_step; eauto.
  Qed.

  Lemma wp_case_inr E e0 v0 e1 e2 Φ :
    to_val e0 = Some v0 →
    ▷ WP e2.[e0/] @ E {{ Φ }} ⊢ WP Case (InjR e0) e1 e2 @ E {{ Φ }}.
  Proof.
    intros. rewrite -(wp_lift_pure_det_head_step' (Case _ _ _) (e2.[e0/])); eauto.
    intros; inv_head_step; eauto.
  Qed.
End lang_rules.


From Coq Require Import String ZArith NArith Eqdep_dec List Lia.

From Coq Require PropExtensionality.

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

From Vyper.From20To30 Require Import Translate Callset FunCtx Expr Stmt.

Lemma nodup_app {A: Type} (EqDec: forall x y: A, {x = y} + {x <> y})
                {a b: list A}
                (NA: NoDup a)
                (NB: NoDup b)
                (Disjoint: forall x,
                             (ListSet.set_mem EqDec x a && ListSet.set_mem EqDec x b = false)%bool):
  NoDup (a ++ b).
Proof.
induction a as [|ha]. { apply NB. }
cbn. constructor.
{ (* ~ In ha (a ++ b) *)
  rewrite in_app_iff.
  intro H. case H; clear H; intro H.
  { now inversion NA. }
  assert (Q := Disjoint ha).
  cbn in Q. destruct EqDec. 2:tauto.
  rewrite Bool.andb_true_l in Q.
  now rewrite ListSet2.set_mem_false in Q.
}
apply IHa. { now inversion NA. }
intro x.
assert (U := Disjoint x).
cbn in U.
destruct EqDec. 2:assumption.
now destruct (ListSet.set_mem EqDec x a).
Qed.

Lemma nodup_app_elim_r {A: Type} (EqDec: forall x y: A, {x = y} + {x <> y})
                       {a b: list A}
                       (H: NoDup (a ++ b)):
  NoDup b.
Proof.
induction a as [|ha]. { apply H. }
cbn in H. apply IHa. inversion H. assumption.
Qed.

Lemma nodup_disjoint {A: Type} (EqDec: forall x y: A, {x = y} + {x <> y})
                     {a b: list A}
                     (H: NoDup (a ++ b))
                     (x: A):
  (ListSet.set_mem EqDec x a && ListSet.set_mem EqDec x b = false)%bool.
Proof.
induction a as [|ha]. { easy. }
cbn.
destruct (EqDec x ha). 2:{ inversion H. tauto. }
subst x.
rewrite Bool.andb_true_l.
rewrite ListSet2.set_mem_false.
cbn in H.
assert (W: ~ In ha (a ++ b)) by now inversion H.
rewrite in_app_iff in W. tauto.
Qed.

Lemma alist_set_mem {A B: Type} (EqDec: forall x y: A, {x = y} + {x <> y})
                    (x: A) (alist: list (A * B)):
  ListSet.set_mem EqDec x (map fst alist)
   =
  match Map.alist_lookup EqDec alist x with
  | Some _ => true
  | None => false
  end.
Proof.
induction alist. { easy. }
cbn. rewrite IHalist.
destruct a as (k, v). cbn.
now destruct (EqDec x k).
Qed.

(** [make_varmap] builds a varmap successfully if there's no duplicate variable name. *)
Lemma varmap_if_nodup {C: VyperConfig}
                      (names: list string)
                      (ND: NoDup names)
                      (err: string):
  make_varmap names <> inl err.
Proof.
unfold make_varmap.
pose (empty  := @Map.empty  string string_dec N (@string_map C N) (@string_map_impl C N)).
pose (items  := @Map.items  string string_dec N (@string_map C N) (@string_map_impl C N)).
pose (insert := @Map.insert string string_dec N (@string_map C N) (@string_map_impl C N)).
fold empty.
assert (ND': NoDup (map fst (items empty) ++ names)).
{ unfold empty. unfold items. rewrite Map.empty_items. cbn. exact ND. }
enough (H: forall m n,
             NoDup (map fst (items m) ++ names)
              ->
             make_varmap_rec m n names <> inl err).
{ apply H. apply ND'. }
clear ND ND'.
induction names; intros m n H. { easy. }
cbn.
rewrite Map.items_ok.
destruct (NoDup_remove _ _ _ H) as (H', NotIn).
rewrite in_app_iff in NotIn.
rewrite Map.alist_lookup_not_in by tauto.
apply IHnames.
(* goal: NoDup (map fst (items (Map.insert m a n)) ++ names) *)
apply (nodup_app string_dec).
{ apply Map.items_nodup. }
{ apply (nodup_app_elim_r string_dec H'). }
(* disjoint *)
intro x.
assert (D := nodup_disjoint string_dec H x).
cbn in D.
assert (F: ListSet.set_mem string_dec x (map fst (items (insert m a n)))
            =
           if string_dec x a then true else ListSet.set_mem string_dec x (map fst (items m))).
{
  repeat rewrite alist_set_mem. unfold items. repeat rewrite<- Map.items_ok.
  unfold insert. rewrite Map.insert_ok.
  destruct (string_dec a x), (string_dec x a); now subst.
}
fold insert. rewrite F. clear F.
destruct (ListSet.set_mem string_dec x (map fst (items m))), (string_dec x a); try easy.
rewrite Bool.andb_true_l.
rewrite ListSet2.set_mem_false.
subst x. tauto.
Qed.

Lemma varmap_rec_not_in {C: VyperConfig}
                        (a: string)
                        (names: list string)
                        (m: string_map N)
                        (init: N)
                        (L: let _ := string_map_impl in Map.lookup m a <> None)
                        (Ok: forall err, make_varmap_rec m init names <> inl err):
  ~ In a names.
Proof.
pose (insert := @Map.insert string string_dec N (@string_map C N) (@string_map_impl C N)).
revert m init L Ok. induction names as [|head]; intros. { easy. }
cbn in *.
remember (Map.lookup m head) as m_head. destruct m_head.
{ exfalso. exact (Ok _ eq_refl). }
assert (NE: head <> a).
{ intro. subst. rewrite<- Heqm_head in L. tauto. }
enough (~ In a names) by tauto.
apply (IHnames (insert m head init) (N.succ init)).
2: apply Ok.
unfold insert.
rewrite Map.insert_ok.
now destruct (string_dec head a).
Qed.

Lemma varmap_rec_cons {C: VyperConfig}
                      (head: string)
                      (tail: list string)
                      (m: string_map N)
                      (init: N)
                      (Ok: forall err, make_varmap_rec m init (head :: tail) <> inl err):
  ~ In head tail.
Proof.
cbn in Ok.
destruct (Map.lookup m head). { exfalso. exact (Ok _ eq_refl). }
refine (varmap_rec_not_in head tail _ _ _ Ok).
cbn. rewrite Map.insert_ok.
now destruct (string_dec head head).
Qed.

(** If [make_varmap names] finished successfully, then there's no duplicates in [names]. *)
Lemma varmap_nodup {C: VyperConfig}
                   (names: list string)
                   (Ok: forall err, make_varmap names <> inl err):
  NoDup names.
Proof.
unfold make_varmap in Ok.
pose (empty  := @Map.empty  string string_dec N (@string_map C N) (@string_map_impl C N)).
pose (items  := @Map.items  string string_dec N (@string_map C N) (@string_map_impl C N)).
pose (insert := @Map.insert string string_dec N (@string_map C N) (@string_map_impl C N)).
pose (lookup := @Map.lookup string string_dec N (@string_map C N) (@string_map_impl C N)).
fold empty in Ok.
enough (H: forall (m: string_map N)
               (init: N)
               (Disjoint: forall x,
                            match lookup m x with
                            | Some _ => ~ In x names
                            | None => True
                            end)
               (Success: forall err, make_varmap_rec m init names <> inl err),
            NoDup names).
{
  apply (H empty 0%N); try assumption.
  unfold lookup. unfold empty. intro x. now rewrite Map.empty_lookup.
}
clear Ok.
induction names. { constructor. }
intros.
assert (V := varmap_rec_cons a names m init Success).
cbn in Success.
remember (Map.lookup m a) as ma.
destruct ma. { exfalso. exact (Success "duplicate argument name"%string eq_refl). }
constructor. { exact V. }
refine (IHnames (insert m a init) (N.succ init) _ Success).
intro x.
unfold lookup in *. unfold insert. rewrite Map.insert_ok.
cbn in Disjoint. assert (Dx := Disjoint x).
destruct (string_dec a x). { now subst. }
destruct (Map.lookup m x); tauto.
Qed.

(** Given that [names] and [values] have the same length and there is no duplication in [names],
    [bind_args] computes successfully and returns a map that is only defined on strings from [names].
 *)
Lemma bind_args_domain_if_nodup {C: VyperConfig}
                                (names: list string)
                                (values: list uint256)
                                (SameLen: length names = length values)
                                (ND: NoDup names):
  let _ := string_map_impl in
  match L10.Interpret.bind_args names values with
  | inl err => False
  | inr m => forall x,
               match Map.lookup m x with
               | None => ~ In x names
               | Some _ => In x names
               end
  end.
Proof.
revert values SameLen. induction names, values; try easy.
{ cbn. intro H. clear H. intro x. now rewrite Map.empty_lookup. }
cbn. intro SameLen'.
assert (L: length names = length values) by now inversion SameLen'. clear SameLen'.
assert (ND_names: NoDup names) by now inversion ND.
assert (IH := IHnames ND_names values L).
destruct (Interpret.bind_args names values). { exact IH. }
assert (A := IH a). destruct (Map.lookup s a). { now inversion ND. }
intro x.
assert (X := IH x). rewrite Map.insert_ok.
destruct (string_dec a x). { now left. }
destruct Map.lookup; tauto.
Qed.

(** This is a variant of [bind_args_domain_if_nodup] but it directly assumes
    successful completion of [bind_args] instead of preconditions. *)
Lemma bind_args_domain {C: VyperConfig}
                   (names: list string)
                   (values: list uint256)
                   (loc: string_map uint256)
                   (Ok: L10.Interpret.bind_args names values = inr loc):
  let _ := string_map_impl in
     forall x,
       match Map.lookup loc x with
       | None => ~ In x names
       | Some _ => In x names
       end.
Proof.
revert values loc Ok. induction names as [|head_name], values as [|head_value]; try easy; intros.
{ cbn in *. inversion Ok. subst. now rewrite Map.empty_lookup. }
cbn in *.
remember (Interpret.bind_args names values) as loc'. destruct loc' as [|loc']. { discriminate. }
assert (IH := IHnames _ _ (eq_sym Heqloc') x).
destruct (Map.lookup loc' head_name). { discriminate. }
inversion Ok. subst. rewrite Map.insert_ok.
destruct (string_dec head_name x).
{ subst. left. trivial. }
destruct (Map.lookup loc' x); tauto.
Qed.

Lemma bind_args_lt {C: VyperConfig}
                   (names: list string)
                   (values: list uint256)
                   (L: length names < length values)
                   (ND: NoDup names):
   L10.Interpret.bind_args names values = inl "function called with too many arguments"%string.
Proof.
revert values L. induction names, values; intros; try easy.
cbn.
assert (ND': NoDup names) by now inversion ND.
cbn in L. apply lt_S_n in L.
now rewrite (IHnames ND' values L).
Qed.

Lemma bind_args_gt {C: VyperConfig}
                   (names: list string)
                   (values: list uint256)
                   (G: length values < length names)
                   (ND: NoDup names):
   L10.Interpret.bind_args names values = inl "function called with too few arguments"%string.
Proof.
revert values G. induction names, values; intros; try easy.
cbn.
assert (ND': NoDup names) by now inversion ND.
cbn in G. apply gt_S_n in G.
now rewrite (IHnames ND' values G).
Qed.

Lemma bind_args_nodup {C: VyperConfig}
                      (names: list string)
                      (values: list uint256)
                      (loc: string_map uint256)
                      (Ok: L10.Interpret.bind_args names values = inr loc):
  NoDup names.
Proof.
revert values loc Ok. induction names as [|head_name], values as [|head_value]; intros; try easy.
{ constructor. }
cbn in Ok.
remember (Interpret.bind_args names values) as loc'. destruct loc' as [|loc']; try discriminate.
remember (Map.lookup loc' head_name) as loc'_head. destruct loc'_head; try discriminate.
constructor.
{
  assert (D := bind_args_domain _ _ _ (eq_sym Heqloc') head_name).
  now rewrite<- Heqloc'_head in D.
}
exact (IHnames values loc' (eq_sym Heqloc')).
Qed.

Lemma bind_args_same_len {C: VyperConfig}
                         (names: list string)
                         (values: list uint256)
                         (loc: string_map uint256)
                         (Ok: L10.Interpret.bind_args names values = inr loc):
  length names = length values.
Proof.
assert (T := Nat.lt_trichotomy (length names) (length values)).
case T; clear T; intro T.
{
  rewrite bind_args_lt in Ok. { discriminate. } { assumption. }
  apply (bind_args_nodup _ _ _ Ok).
}
case T; clear T; intro T. { assumption. }
rewrite bind_args_gt in Ok. { discriminate. } { assumption. }
apply (bind_args_nodup _ _ _ Ok).
Qed.

Lemma varmap_rec_ok {C: VyperConfig}
                    (names: list string)
                    (varmap: string_map N)
                    (m: string_map N)
                    (init: N)
                    (Bound: VarsBound m init)
                    (Inj: VarmapInj m)
                    (Ok: make_varmap_rec m init names = inr varmap):
  VarmapInj varmap /\ VarsBound varmap (init + N.of_nat (length names))%N.
Proof.
pose (empty  := @Map.empty  string string_dec N (@string_map C N) (@string_map_impl C N)).
pose (insert := @Map.insert string string_dec N (@string_map C N) (@string_map_impl C N)).
pose (lookup := @Map.lookup string string_dec N (@string_map C N) (@string_map_impl C N)).
revert m init Bound Inj Ok. induction names; cbn; intros.
{
  assert (m = varmap) by now inversion Ok.
  subst varmap. rewrite N.add_0_r. tauto.
}
remember (Map.lookup m a) as ma. destruct ma. { discriminate. }
replace (init + N.pos (Pos.of_succ_nat (Datatypes.length names)))%N
   with (N.succ init + N.of_nat (Datatypes.length names))%N by lia.
refine (IHnames (insert m a init) (N.succ init) _ _ Ok).
{
  (* VarsBound (insert m a init) (N.succ init) *)
  intro x.
  unfold insert. rewrite Map.insert_ok.
  assert (B := Bound x).
  destruct (string_dec a x). { apply N.lt_succ_diag_r. }
  destruct (Map.lookup m x) as [k|]. 2:trivial.
  lia.
}
intros x y.
unfold insert. repeat rewrite Map.insert_ok.
destruct (string_dec a x).
{
  destruct (string_dec a y). { now subst. }
  assert (B := Bound y).
  destruct (Map.lookup m y) as [k|]. 2:trivial.
  intro H. lia.
}
destruct (string_dec a y).
{
  assert (B := Bound x).
  destruct (Map.lookup m x) as [k|]. 2:trivial.
  intro H. lia.
}
apply Inj.
Qed.

Lemma varmap_ok {C: VyperConfig}
                (names: list string)
                (varmap: string_map N)
                (Ok: make_varmap names = inr varmap):
  VarmapInj varmap /\ VarsBound varmap (N.of_nat (length names))%N.
Proof.
unfold make_varmap in *.
pose (empty  := @Map.empty  string string_dec N (@string_map C N) (@string_map_impl C N)).
assert (R := varmap_rec_ok names varmap empty 0%N).
cbn in R. apply R.
{ (* VarsBound empty 0 *) intro x. unfold empty. now rewrite Map.empty_lookup. }
{ (* VarmapInj empty *) intros x y. unfold empty. now rewrite Map.empty_lookup. }
apply Ok.
Qed.

Lemma varmap_rec_mono {C: VyperConfig}
                      (names: list string)
                      (m varmap: string_map N)
                      (init: N)
                      (VarmapOk: make_varmap_rec m init names = inr varmap)
                      (x: string):
  let _ := string_map_impl in
  match Map.lookup m x with
  | Some y => Map.lookup varmap x = Some y
  | None => True
  end.
Proof.
revert m init VarmapOk.
induction names as [|head]; intros; cbn in *.
{ inversion VarmapOk. subst varmap. now destruct Map.lookup. }
remember (Map.lookup m head) as m_head. destruct m_head. { discriminate. }
assert (IH := IHnames _ _ VarmapOk).
rewrite Map.insert_ok in IH.
destruct (string_dec head x).
{ subst. now destruct (Map.lookup m x). }
apply IH.
Qed.

Local Lemma varmap_rec_index {C: VyperConfig}
                             (names: list string)
                             (m varmap: string_map N)
                             (init: N)
                             (VarmapOk: make_varmap_rec m init names = inr varmap)
                             (x: string):
  let _ := string_map_impl in
  match Map.lookup m x, Map.lookup varmap x with
  | None, Some index => (init <= index)%N /\ nth_error names (N.to_nat (index - init)%N) = Some x
  | _, _ => ~ In x names
  end.
Proof.
revert m varmap init VarmapOk x. induction names as [|head]; intros; cbn in *.
{
  inversion VarmapOk; subst varmap.
  now destruct (Map.lookup m x).
}
remember (Map.lookup m head) as m_head. destruct m_head. { discriminate. }
assert (IH := IHnames _ _ _ VarmapOk x).
rewrite Map.insert_ok in IH.
destruct (string_dec head x).
{
  subst head.
  destruct (Map.lookup m x). { discriminate. }
  assert (V := varmap_rec_mono _ _ _ _ VarmapOk x).
  cbn in V. rewrite Map.insert_ok in V.
  destruct (string_dec x x). 2:tauto.
  destruct (Map.lookup varmap x). 2:discriminate.
  inversion V. subst.
  rewrite N.sub_diag.
  split. { lia. }
  trivial.
}
destruct (Map.lookup m x). { tauto. }
destruct (Map.lookup varmap x) as [k|]. 2:tauto.
remember (N.to_nat (k - N.succ init)) as a.
remember (N.to_nat (k - init)) as b.
destruct IH as (Bound, E).
assert (B: b = S a) by lia.
rewrite B.
cbn.
split. 2:assumption.
lia.
Qed.

(** If [make_varmap] finishes succesfully, the result maps a name to its index in the [names] list. *)
Lemma varmap_index {C: VyperConfig}
                   (names: list string)
                   (varmap: string_map N)
                   (VarmapOk: make_varmap names = inr varmap)
                   (x: string):
  let _ := string_map_impl in
  match Map.lookup varmap x with
  | Some index => nth_error names (N.to_nat index) = Some x
  | None => ~ In x names
  end.
Proof.
unfold make_varmap in VarmapOk.
cbn.
assert (R := varmap_rec_index _ _ _ _ VarmapOk x). cbn in R.
rewrite Map.empty_lookup in R.
destruct (Map.lookup varmap x). 2:tauto.
rewrite N.sub_0_r in R.
tauto.
Qed.

Lemma bind_args_index {C: VyperConfig}
                      (names: list string)
                      (values: list uint256)
                      (loc: string_map uint256)
                      (LocOk: L10.Interpret.bind_args names values = inr loc)
                      (index: nat)
                      (x: string)
                      (Ok: nth_error names index = Some x):
  let _ := string_map_impl in
  Map.lookup loc x = nth_error values index.
Proof.
cbn. revert index values loc LocOk Ok.
induction names as [|head_name], values as [|head_value]; intros; try easy.
{
  assert (Oops: index < @length string nil).
  { apply nth_error_Some. intro H. rewrite H in Ok. discriminate. }
  cbn in Oops.
  now apply Nat.nlt_0_r in Oops.
}
assert (F := bind_args_nodup _ _ _ LocOk).
cbn in LocOk.
remember (Interpret.bind_args names values) as loc'.
destruct loc' as [|loc']. { discriminate. }
remember (Map.lookup loc' head_name) as loc'_head. destruct loc'_head. { discriminate. }
symmetry in Heqloc'.
inversion LocOk. subst.
rewrite Map.insert_ok.
destruct index as [|index'].
{
  cbn in *. inversion Ok. subst.
  destruct (string_dec x x); tauto.
}
cbn in *.
rewrite<- (IHnames _ _ _ Heqloc' Ok).
destruct (string_dec head_name x). 2:trivial.
subst.
apply nth_error_In in Ok.
inversion F. contradiction.
Qed.

Lemma bind_varmap_agree {C: VyperConfig}
                        (names: list string)
                        (values: list uint256)
                        (varmap: string_map N)
                        (loc: string_map uint256)
                        (VarmapOk: make_varmap names = inr varmap)
                        (LocOk: L10.Interpret.bind_args names values = inr loc):
  let _ := memory_impl in
  VarsAgree varmap loc (OpenArray.from_list values).
Proof.
cbn. intro x.
assert (V := varmap_index _ _ VarmapOk x). cbn in V.
assert (D := bind_args_domain _ _ _ LocOk x).
remember (Map.lookup varmap x) as varmap_x.
destruct varmap_x. 2:now destruct (Map.lookup loc x).
rewrite OpenArray.from_list_ok.
assert (W := bind_args_index _ _ _ LocOk _ _ V). cbn in W.
rewrite W in *.
assert (L := bind_args_same_len _ _ _ LocOk).
assert (BN: N.to_nat n < length names).
{ apply nth_error_Some. rewrite V. discriminate. }
assert (BV: N.to_nat n < length values). { rewrite<- L. apply BN. }
remember (nth_error values (N.to_nat n)) as z. symmetry in Heqz. destruct z.
2:{ apply nth_error_Some in BV. contradiction. }
apply nth_error_nth with (d := uint256_of_Z 0) in Heqz. exact Heqz.
Qed.

Lemma interpret_translated_call {C: VyperConfig}
                                (builtins: string -> option builtin)
                                {cd20: L20.Descend.calldag}
                                {call_depth_bound: nat}
                                (fc: fun_ctx cd20 call_depth_bound)
                                {cd30: L30.Descend.calldag}
                                (ok: translate_calldag cd20 = inr cd30)
                                (world: world_state)
                                (arg_values: list uint256):
  L30.Interpret.interpret_call builtins (translate_fun_ctx fc ok) world arg_values
   =
  L20.Interpret.interpret_call builtins fc world arg_values.
Proof.
revert world arg_values. induction call_depth_bound.
{ exfalso. exact (Nat.nlt_0_r _ (proj1 (Nat.ltb_lt _ _) (fun_bound_ok fc))). }
assert(F: inr (cached_translated_decl fc ok)
           =
          translate_decl (fun_decl fc)).
{
  clear IHcall_depth_bound.
  unfold translate_fun_ctx in *. cbn in *.
  unfold cached_translated_decl in *.
  remember (FunCtx.translate_fun_ctx_fun_decl_helper fc ok) as foo. clear Heqfoo.
  remember (cd_declmap cd30 (fun_name fc)) as d.
  destruct d. 2:{ contradiction. }
  subst.
  assert (Q := translate_fun_ctx_declmap ok (fun_name fc)).
  destruct (cd_declmap cd30 (fun_name fc)) as [d'|]. 2:discriminate.
  inversion Heqd. subst d'. clear Heqd.
  remember (cd_declmap cd20 (fun_name fc)) as x.
  destruct x as [x|]. 2:discriminate.
  inversion Q. f_equal.
  assert (D := fun_decl_ok fc).
  rewrite D in *. inversion Heqx.
  trivial.
}
intros.
cbn.
remember (fun name arity body
              (E: cached_translated_decl fc ok = AST.FunDecl name arity body) =>
          if Datatypes.length arg_values =? N.to_nat arity
          then
           let
           '(world', _, result) :=
            Stmt.interpret_stmt eq_refl (translate_fun_ctx fc ok) (Interpret.interpret_call builtins)
              builtins world (OpenArray.from_list arg_values) body (Interpret.interpret_call_helper E) in
            (world', _)
          else (world,
     expr_error
       (if match N.to_nat arity with
           | 0 => false
           | S m' => Datatypes.length arg_values <=? m'
           end
        then "function called with too few arguments"%string
        else "function called with too many arguments"%string))) as branch_30.
remember (fun name arg_names body
              (E : fun_decl fc = L20.AST.FunDecl name arg_names body) =>
            match Interpret.bind_args arg_names arg_values with
            | inl err => (world, expr_error err)
            | inr loc =>
                let
                '(world', _, result) :=
                 L20.Stmt.interpret_stmt eq_refl fc (L20.Interpret.interpret_call builtins) builtins world loc
                   body (L20.Interpret.interpret_call_helper E) in
                 (world', _)
            end) as branch_20.
assert (B: forall name arg_names body30 body20 E30 E20,
             branch_30 name (N.of_nat (List.length arg_names)) body30 E30
              =
             branch_20 name arg_names body20 E20).
{
  intros. subst. rewrite Nat2N.id. rewrite E20 in F. rewrite E30 in F. cbn in F.
  remember (make_varmap arg_names) as maybe_varmap.
  destruct maybe_varmap as [err|varmap]. { discriminate. }
  (* argument names have no duplication because translation would have failed *)
  assert (ND: NoDup arg_names).
  { apply varmap_nodup. intro err. rewrite<- Heqmaybe_varmap. discriminate. }

  (* arity check *)
  assert (T := Nat.lt_trichotomy (length arg_names) (length arg_values)).
  case T; clear T; intro T.
  {
    replace (length arg_values =? length arg_names) with false.
    2:{ symmetry. rewrite Nat.eqb_neq. apply Nat.neq_sym. apply Nat.lt_neq. exact T. }
    replace (match length arg_names with
             | 0 => false
             | S m' => length arg_values <=? m'
             end) with (length arg_values <? length arg_names) by trivial.
    replace (length arg_values <? length arg_names) with false.
    2:{ symmetry. rewrite Nat.ltb_ge. apply Nat.lt_le_incl. exact T. }
    now rewrite (bind_args_lt _ _ T ND).
  }
  case T; clear T; intro T.
  2:{
    replace (length arg_values =? length arg_names) with false.
    2:{ symmetry. rewrite Nat.eqb_neq. apply Nat.lt_neq. exact T. }
    replace (match length arg_names with
         | 0 => false
         | S m' => length arg_values <=? m'
         end) with (length arg_values <? length arg_names) by trivial.
    assert (G := T).
    rewrite<- Nat.ltb_lt in T. rewrite T.
    now rewrite (bind_args_gt _ _ G ND).
  }
  assert (SameLen := T).
  symmetry in T. rewrite<- Nat.eqb_eq in T. rewrite T. clear T.

  assert (BindArgsOk := bind_args_domain_if_nodup arg_names arg_values SameLen ND).
  remember (Interpret.bind_args arg_names arg_values) as loc.
  destruct loc as [err|loc]. { contradiction. }
  destruct (varmap_ok arg_names varmap (eq_sym Heqmaybe_varmap)) as (Inj, Bound).
  remember (translate_stmt varmap (N.of_nat (Datatypes.length arg_names)) body20) as body30'.
  destruct body30'. { discriminate. }
  inversion F. subst.
  assert (IS := interpret_translated_stmt eq_refl builtins fc ok
                                          IHcall_depth_bound world loc
                                          (OpenArray.from_list arg_values)
                                          varmap Inj _
                                          (bind_varmap_agree _ _ _ _
                                            (eq_sym Heqmaybe_varmap)
                                            (eq_sym Heqloc))
                                          Bound
                                          (eq_sym Heqbody30')
                                          (L30.Interpret.interpret_call_helper E30)
                                          (L20.Interpret.interpret_call_helper E20)).
  cbn in IS.
  destruct L30.Stmt.interpret_stmt as ((world30, mem30), result30).
  destruct L20.Stmt.interpret_stmt as ((world20, loc20), result20).
  destruct IS as (R, (W, Agree)).
  subst.
  trivial.
}
clear Heqbranch_20. clear Heqbranch_30.
destruct (fun_decl fc); cbn in F.
{ (* [fun_decl fc] is a global var *) now destruct cached_translated_decl. }
destruct (make_varmap args). { discriminate. }
destruct (translate_stmt s (N.of_nat (Datatypes.length args)) body). { discriminate. }
inversion F.
destruct (cached_translated_decl fc ok). { discriminate. }
inversion H0 (* XXX *). subst.
apply B.
Qed.

Lemma make_fun_ctx_and_bound_ok {C: VyperConfig}
                                (cd20: L20.Descend.calldag)
                                (cd30: L30.Descend.calldag)
                                (Ok: translate_calldag cd20 = inr cd30)
                                (fun_name: string):
   make_fun_ctx_and_bound cd30 fun_name
    =
   match make_fun_ctx_and_bound cd20 fun_name with
   | Some (existT _ bound fc) => Some (existT _ bound (translate_fun_ctx fc Ok))
   | None => None
   end.
Proof.
(* this is too complicated due to destructing convoys *)
unfold make_fun_ctx_and_bound.
remember (fun d (Ed : cd_declmap cd30 fun_name = Some d) =>
    match
      cd_depthmap cd30 fun_name as depth'
      return (cd_depthmap cd30 fun_name = depth' -> option {bound : nat & fun_ctx cd30 bound})
    with
    | Some depth =>
        fun Edepth : cd_depthmap cd30 fun_name = Some depth =>
        Some
          (existT (fun bound : nat => fun_ctx cd30 bound) (S depth)
             {|
             fun_name := fun_name;
             fun_depth := depth;
             fun_depth_ok := Edepth;
             fun_decl := d;
             fun_decl_ok := Ed;
             fun_bound_ok := proj2 (Nat.ltb_lt depth (S depth)) (Nat.lt_succ_diag_r depth) |})
    | None =>
        fun Edepth : cd_depthmap cd30 fun_name = None =>
        False_rect (option {bound : nat & fun_ctx cd30 bound}) (Calldag.make_fun_ctx_helper Ed Edepth)
    end eq_refl) as lhs_some_branch.
remember (fun d (Ed : cd_declmap cd20 fun_name = Some d) =>
      match
        cd_depthmap cd20 fun_name as depth'
        return (cd_depthmap cd20 fun_name = depth' -> option {bound : nat & fun_ctx cd20 bound})
      with
      | Some depth =>
          fun Edepth : cd_depthmap cd20 fun_name = Some depth =>
          Some
            (existT (fun bound : nat => fun_ctx cd20 bound) (S depth)
               {|
               fun_name := fun_name;
               fun_depth := depth;
               fun_depth_ok := Edepth;
               fun_decl := d;
               fun_decl_ok := Ed;
               fun_bound_ok := proj2 (Nat.ltb_lt depth (S depth)) (Nat.lt_succ_diag_r depth) |})
      | None =>
          fun Edepth : cd_depthmap cd20 fun_name = None =>
          False_rect (option {bound : nat & fun_ctx cd20 bound})
            (Calldag.make_fun_ctx_helper Ed Edepth)
      end eq_refl) as rhs_some_branch.
enough (SomeBranchOk: forall d30 d20 Ed30 Ed20
                             (DeclOk: translate_decl d20 = inr d30),
                        lhs_some_branch d30 Ed30
                         =
                        match rhs_some_branch d20 Ed20 with
                        | Some (existT _ bound fc) =>
                            Some
                              (existT _ bound
                                 (translate_fun_ctx fc Ok))
                        | None => None
                        end).
{
  cbn in *.
  remember (fun _: _ = None => None) as lhs_none_branch.
  assert (NoneBranchOk: forall E, lhs_none_branch E = None).
  { subst. trivial. }
  clear Heqlhs_some_branch Heqrhs_some_branch Heqlhs_none_branch.
  assert (T := translate_fun_ctx_declmap Ok fun_name).
  destruct (cd_declmap cd20 fun_name); destruct (cd_declmap cd30 fun_name);
    try easy.
  apply SomeBranchOk.
  now inversion T.
}
subst. cbn. intros.

(* This is even more messed up than usual because just the implicit arguments weren't enough. *)
remember (fun depth
       (Edepth : @eq (option nat)
                    (@cd_depthmap C (@AST.decl C) (@Callset.decl_callset C) false cd30 fun_name)
                    (@Some nat depth)) =>
       @Some
         (@sigT nat (fun bound : nat => @fun_ctx C (@AST.decl C) (@Callset.decl_callset C) false cd30 bound))
         (@existT nat
            (fun bound : nat => @fun_ctx C (@AST.decl C) (@Callset.decl_callset C) false cd30 bound)
            (S depth)
            _))
  as depth_lhs_some_branch.
remember (fun (depth: nat)
        (Edepth: cd_depthmap cd20 fun_name = Some depth) =>
      Some
        (existT (fun bound : nat => fun_ctx cd20 bound) (S depth)
           _))
  as depth_rhs_some_branch.
enough (A: forall depth E30 E20,
          depth_lhs_some_branch depth E30
           =
          match depth_rhs_some_branch depth E20 with
          | Some (existT _ bound fc) =>
              Some
                (existT (fun bound0 : nat => fun_ctx cd30 bound0) bound
                   (translate_fun_ctx fc Ok))
          | None => None
          end).
{
  clear Heqdepth_lhs_some_branch Heqdepth_rhs_some_branch.
  remember (fun Edepth : cd_depthmap cd30 fun_name = None =>
      False_rect (option {bound : nat & fun_ctx cd30 bound}) (Calldag.make_fun_ctx_helper Ed30 Edepth))
    as lhs_none_branch.
  remember (fun Edepth : cd_depthmap cd20 fun_name = None =>
        False_rect (option {bound : nat & fun_ctx cd20 bound}) (Calldag.make_fun_ctx_helper Ed20 Edepth))
    as rhs_none_branch.
  clear Heqlhs_none_branch Heqrhs_none_branch.
  assert (Guard30 := Calldag.make_fun_ctx_helper Ed30).
  assert (Guard20 := Calldag.make_fun_ctx_helper Ed20).
  assert (T := translate_fun_ctx_depthmap Ok fun_name).
  destruct (cd_depthmap cd30 fun_name), (cd_depthmap cd20 fun_name); try easy.
  inversion T. subst.
  apply A.
}
intros. subst.
f_equal. f_equal.
unfold translate_fun_ctx. cbn.
assert (FunCtxEq: forall name1 depth depth_ok1 decl1 decl_ok1 bound_ok1
                         name2       depth_ok2 decl2 decl_ok2 bound_ok2
                         (Name: name1 = name2)
                         (Decl: decl1 = decl2),
  ({| fun_name := name1
    ; fun_depth := depth
    ; fun_depth_ok := depth_ok1
    ; fun_decl := decl1
    ; fun_decl_ok := decl_ok1
    ; fun_bound_ok := bound_ok1 |}: fun_ctx cd30 (S depth))
   =
  {| fun_name := name2
   ; fun_depth := depth
   ; fun_depth_ok := depth_ok2
   ; fun_decl := decl2
   ; fun_decl_ok := decl_ok2
   ; fun_bound_ok := bound_ok2 |}).
{
  intros. subst.
  assert (depth_ok1 = depth_ok2) by apply PropExtensionality.proof_irrelevance.
  assert (decl_ok1 = decl_ok2) by apply PropExtensionality.proof_irrelevance.
  assert (bound_ok1 = bound_ok2) by apply PropExtensionality.proof_irrelevance.
  subst.
  trivial.
}
apply FunCtxEq. { (* name: *) trivial. }
clear FunCtxEq.
assert (Unsome: forall {T} (x y: T), Some x = Some y -> x = y).
{ intros T x y H. now inversion H. }
apply Unsome.
rewrite<- FunCtx.translate_fun_ctx_decl_ok. cbn. symmetry. exact Ed30.
Qed.

Theorem translate_ok {C: VyperConfig}
                     (builtins: string -> option builtin)
                     (cd20: L20.Descend.calldag)
                     (cd30: L30.Descend.calldag)
                     (Ok: translate_calldag cd20 = inr cd30)
                     (fun_name: string)
                     (world: world_state)
                     (arg_values: list uint256):
  L30.Interpret.interpret builtins cd30 fun_name world arg_values
   =
  L20.Interpret.interpret builtins cd20 fun_name world arg_values.
Proof.
unfold L20.Interpret.interpret. unfold L30.Interpret.interpret.
rewrite (make_fun_ctx_and_bound_ok cd20 cd30 Ok).
destruct (make_fun_ctx_and_bound cd20 fun_name) as [(bound, fc)|]; cbn.
{ apply interpret_translated_call. }
trivial.
Qed.


(**
Rainbow, a termination proof certification tool

See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2011-04-06

* CPF correctness checker main

*)

Set Implicit Arguments.

Require Import ATrs SN ZArith EqUtil String List ListDec ListForall
  ListUtil ZUtil LogicUtil BoolUtil VecUtil NArith NatUtil ADP
  cpf2color cpf rainbow_main_termin AVarCond cpf_util
  correctnessproof_full_termin RelUtil correctnessproof_top_termin
  rainbow_full_termin rainbow_top_termin correctnessproof_non_termin
  rainbow_non_termin.

Section S.

  (** [nat_of_string]: convert a variable map to natural number. *)

  Variable nat_of_string: string -> nat.

  (** [n: nat] is an artificial extra argument which purpose is to
     make the function [dpProof] structually recursive with respect to
     this argument. *)

  Variable n : nat.

  (** Assume variable [bb] in [rpo]. *)

  Variable bb : nat.

  Section Termination.

    (***********************************************************************)
    (** Check that [R] is a trivial proof by stating the set of rules [R] is
     empty valid termination proof for [red R]. *)

    Lemma trsTerminationProof_rIsEmpty_ok :
      forall a (R: arules a), trsTerminationProof_rIsEmpty R = OK -> WF (red R).

    Proof.
      intros a R. unfold trsTerminationProof_rIsEmpty.
      destruct R; simpl; intro. apply WF_red_empty. discr.
    Qed.

    (***********************************************************************)
    (** ** REMOVE Check that termination proof is valid termination proof for
     [red R]. *)
    (*
    Variables is_notvar_lhs_dp :
      forall a R,forallb (@is_notvar_lhs (Sig a)) (dp R) = true.

    (** No rule right hand side is a variable in [dp R]. *)

    Variables is_notvar_rhs_dp :
      forall a R, forallb (@is_notvar_rhs (Sig a)) (dp R) = true. *)

    (***********************************************************************)
    (** Correctness proof of string reverse in trsTermination proof. *)
    (* MOVE *)
    Require Import AReverse AUnary.

    Lemma string_reverse_ok :
      forall a t (rs: arules a) trs
             (Hm : trsTerminationProof nat_of_string n bb (reverse_trs rs) t = OK)
             (H : brules_preserve_vars rs = true)
             (H0 : bis_unary (Sig a) (symbol_in_rules trs) = true),
        WF (red rs).

    Proof.
      intros a t rs trs Hm H H0.
    Admitted.

    (***********************************************************************)
    (** Correctness proof of trsTermination proof. *)

    Lemma trsTerminationProof_ok :
      forall a R t i,
        sys_of_input a nat_of_string i = Ok (Red R) ->
        trsTerminationProof nat_of_string n bb R t = OK ->
        WF (red R).

    Proof.
      intros a r t i H Hs. revert r H Hs. intros rs Hs.
      clear Hs i. revert t rs.
      induction t; intros rs Hm; simpl in Hm; try discr.

      (** Correctness proof when termination proof is empty. *)

      apply trsTerminationProof_rIsEmpty_ok. hyp.

      (** Correctness proof of termination proof in the case of rule
          removal. *)

      destruct o; try discr.
      unfold trsTerminationProof_ruleRemoval in Hm. destruct o0; try discr.
      unfold orderingConstraintProof_redPair in Hm.
      destruct r; try discr.
      revert Hm. case_eq (redPair_interpretation rs t1 l);
                 intros l0 H Hm; try discr.
      eapply redPair_interpretation_ok. apply H. eapply IHt. hyp.

      (** Correctness proof of termination proof in the case of path
          ordering. *)

      revert Hm. case_eq (pathOrder bb rs l o);
      intros l0 H Hm; try discr.

      eapply pathOrdering_ok.
      apply H. eapply IHt. hyp.

      (** Correctness proof of dependency pair transformation method
          with and without mark symbol. *)

      apply trsTerminationProof_dpTrans_ok with
      (bb:=bb)(nat_of_string:=nat_of_string)(n:=n)(dps:=d)(b:=b)(p:=d0).
      hyp. (*hyp. apply Hm.*)

      (** String reversal *)

      case_eq (brules_preserve_vars rs && bis_unary (Sig a) (symbol_in_rules t));
        intros H; rewrite H in Hm; simpl in *; try discr.
      rewrite andb_eq in H. destruct H.
      apply string_reverse_ok with (t:=t0)(trs:=t).
      hyp. hyp. hyp.
    Qed.

    (***********************************************************************)
    (** ** Check that termination proof is valid termination proof for
     [red_mod R D]. *)

    Require Import QArith_base NewPositivePolynom2 NewPolynom2
            NewMonotonePolynom2 APolyInt_MAQ2 NewAPolyInt2 poly_rat
            cpf2color_interpret ARedPair2 ARelation AWFMInterpretation
            OrdRingType2 PositivePolynom.

    (** Relative termination is empty. *)

    Lemma relProof_pIsEmpty_ok :
      forall a (R D: arules a),
        relTerminationProof_rIsEmpty D = OK -> WF (red_mod R D).

    Proof.
      intros a R D. unfold relTerminationProof_rIsEmpty.
      destruct D; simpl; intro. apply WF_red_mod_empty. discr.
    Qed.

    (***********************************************************************)
    (** Correctness proof of relative termination. *)

    Lemma rel_TerminationProof_ok :
      forall a R D t i, sys_of_input a nat_of_string i = Ok (Red_mod R D) ->
                        relTerminationProof R D t = OK -> WF (red_mod R D).

    Proof.
      intros a R D t i H Hs. revert R D H Hs. intros R D Hs.
      clear Hs i. revert t R D.
      induction t; intros R D Hm; simpl in Hm; try discr.

      (** Correctness proof when termination proof is empty. *)

      apply relProof_pIsEmpty_ok. apply Hm.
      apply relProof_pIsEmpty_ok. apply Hm.

      (** Correctness proof of relative termination proof in the case of
       rule removal. *)

      destruct o; try discr.
      unfold rel_trsTerminationProof_ruleRemoval in Hm. destruct o0; try discr.
      unfold rel_orderingConstraintProof_redPair in Hm.
      destruct r; try discr.
      revert Hm. case_eq (rel_redPair_interpretation R D t2 l);
                 intros l0 H Hm; try discr.
      eapply rel_redPair_interpretation_ok. apply H.
      apply IHt. apply Hm.

      (** Correctness proof of string reverse. *)

      case_eq (brules_preserve_vars R && brules_preserve_vars D &&
      bis_unary (Sig a) (symbol_in_rules t)); intros H; rewrite H in Hm; try discr.
      do 2 rewrite andb_eq in H. do 2 destruct H.

      apply WF_red_mod_rev_eq.

      (** Proof that [is_unary] is true. *)

      rewrite <- bis_unary_ok. apply H0.

      (** Proof that [Fs_ok] *)

      Focus 2.

      (** Proof that rule_preserve_vars in D. *)

      rewrite <- brules_preserve_vars_ok. apply H1.

      Focus 2.

      (** Proof that rule_preserve_vars in R. *)

      rewrite <- brules_preserve_vars_ok. apply H.

      Focus 2.

    (* TODO *)
    (* Proof [red_mod (reverse_trs R) (reverse_trs D)] is well-founded *)

    Admitted.

  End Termination.

  (***********************************************************************)
  (** ** Correctness proof of certification problems. *)

  (* [main] for non-termination proof and termination proof where it
   changes [WF(rel_of_sys s)] to [EIS (rel_of_sys s)] to be able to
   proof non-termination problem.*)

  Section main.

    (* REMOVE. *)

    (*Variables is_notvar_lhs_dp :
      forall a R, forallb (@is_notvar_lhs (Sig a)) (dp R) = true.

    (***********************************************************************)
    (** No rule right hand side is a variable in [dp R]. *)

    Variables is_notvar_rhs_dp :
      forall a R, forallb (@is_notvar_rhs (Sig a)) (dp R) = true.*)

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

    Lemma main_ok : forall c, let a := arity_in_pb c in
     forall s, sys_of_pb a nat_of_string c = Ok s ->
               check nat_of_string n bb  a c = OK ->
               not_if (is_nontermin_proof c) (EIS (rel_of_sys s)).

    Proof.
      intros c a s Hs Hm. unfold check in Hm. rewrite Hs in Hm.
      destruct c as [[[i st] p] o]. simpl arity_in_pb in *.
      simpl sys_of_pb in *.
      simpl is_nontermin_proof.
      unfold proof in Hm. destruct s; destruct p; try discr; simpl.
      apply WF_notEIS.

      (** Correctness proof of termination problem for [red R]. *)

      apply trsTerminationProof_ok with (t:=t)(i:=i).
      hyp. hyp. (*hyp. hyp.*)

      (** Correctness proof of non-termination problem for [red R]. *)

      unfold trsNonTerminationProof in Hm.
      destruct t; simpl; try discr.
      apply trsNonTerminationProof_variableConditionViolated_ok.
      apply Hm.

      (** Correcntness proof of non-termination for [red R] using loop
       method. There is a loop in TRS. *)

      apply trsNonTerminationProof_loop_ok with (nat_of_string:=nat_of_string)(l:= l).
      destruct l; try discr.
      destruct p; try discr.
      destruct r; try discr.
      destruct l; try discr.
      apply Hm.

      (** Correctness proof of termination problem for [red_mod R D]. *)

      apply WF_notEIS.
      apply rel_TerminationProof_ok with (t:=r)(i:=i).
      hyp. apply Hm.

      (** Correctness proof of non-termination problem for [red_mod R D]. *)
      (*
      unfold relativeNonterminationProof in Hm.
      destruct r; simpl; try discr.

      (** Correctness proof of non-termination proof for [red_mod R D] in
       the case of loop. *)

      apply relativeNonTerminationProof_loop_ok in Hm. apply Hm.

      (** Correctness proof of non-termination proof for [red_mod R D] in
       the case of variable condition violated. *)

      apply relativeNonTerminationProof_variableConditionViolated_ok.
      apply Hm.*)

      (** Correctness proof of termination for top termination
       problems. [hd_red_mod R (dp R)] *)

      apply WF_notEIS. eapply dpProof_ok. apply Hm.

      (* TODO : other cases *)
    Qed.

  End main.

End S.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id: FSets.v 13297 2010-07-19 23:32:42Z letouzey $ *)

Require Export OrderedType.
Require Export OrderedTypeEx.
Require Export OrderedTypeAlt.
Require Export DecidableType.
Require Export DecidableTypeEx.
Require Export FSetInterface.
Require Export FSetBridge.
Require Export FSetFacts.
Require Export FSetDecide.
Require Export FSetProperties.
Require Export FSetEqProperties.
Require Export FSetWeakList.
Require Export FSetList.
Require Export FSetPositive.
Require Export FSetAVL.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Termes.
Require Import Conv.
Require Import Types.
Require Import Class.
Require Import Can.

  (* Interpretations des variables de type *)

  Inductive Int_K : Type :=
    | iK : forall s : skel, Can s -> Int_K
    | iT : Int_K.

  Definition intP := TList Int_K.

  Definition class_of_ik (ik : Int_K) :=
    match ik with
    | iK s _ => Knd s
    | iT => Typ PROP
    end.

  Definition cls_of_int : intP -> cls := Tmap _ _ class_of_ik.

  Definition ext_ik (T : term) (ip : intP) (s : skel)
    (C : Can s) :=
    match cl_term T (cls_of_int ip) with
    | Knd _ => iK s C
    | _ => iT
    end.

  Definition int_cons (T : term) (ip : intP) (s : skel)
    (C : Can s) := TCs _ (ext_ik T ip s C) ip.

  Definition def_cons (T : term) (I : intP) : intP :=
    int_cons T I _ (default_can (cv_skel (cl_term T (cls_of_int I)))).

  Definition skel_int (t : term) (I : intP) :=
    typ_skel (cl_term t (cls_of_int I)).

  Lemma ins_in_cls :
   forall (c : class) (y : Int_K) (k : nat) (ipe ipf : intP),
   class_of_ik y = c ->
   TIns Int_K y k ipe ipf -> TIns _ c k (cls_of_int ipe) (cls_of_int ipf).
unfold cls_of_int in |- *.
simple induction 1.
simple induction 1; simpl in |- *; auto with coc core arith datatypes.
Qed.

  Definition coerce_CR (s : skel) (i : Int_K) : Can s :=
    match i with
    | iK si Ci =>
        match EQ_skel si s with
        | left y =>
            match y in (_ = x) return (Can x) with
            | refl_equal => Ci
            end
        | _ => default_can s
        end
    | _ => default_can s
    end.

  Lemma is_can_coerce :
   forall s s' C, is_can s C -> is_can s' (coerce_CR s' (iK s C)).
Proof.
simpl in |- *; intros.
elim (EQ_skel s s'); intros; auto with coc.
case a; trivial.
Qed.

Hint Resolve is_can_coerce: coc.

  Lemma extr_eq :
   forall (P : forall s : skel, Can s -> Prop) (s : skel) (c : Can s),
   P s c -> P s (coerce_CR s (iK s c)).
Proof.
intros.
unfold coerce_CR in |- *.
elim (EQ_skel s s).
intro Heq.
change
  ((fun s0 (e : s = s0) =>
    P s0 match e in (_ = x) return (Can x) with
         | refl_equal => c
         end) s Heq) in |- *.
case Heq; trivial.

simple induction 1; auto with coc core arith datatypes.
Qed.

  Lemma eq_can_extr :
   forall (s si : skel) (X Y : Can s),
   eq_can s X Y -> eq_can si (coerce_CR si (iK s X)) (coerce_CR si (iK s Y)).
unfold coerce_CR in |- *.
intros.
elim (EQ_skel s si); auto with coc core arith datatypes.
intro Heq; case Heq; auto with coc core arith datatypes.
Qed.

  Hint Resolve eq_can_extr: coc.

  Inductive ik_eq : Int_K -> Int_K -> Prop :=
    | eqi_K :
        forall (s : skel) (X Y : Can s),
        eq_can s X X ->
        eq_can s Y Y -> eq_can s X Y -> ik_eq (iK s X) (iK s Y)
    | eqi_T : ik_eq iT iT.

  Hint Resolve eqi_K eqi_T: coc.

  Lemma iki_K :
   forall (s : skel) (C : Can s), eq_can s C C -> ik_eq (iK s C) (iK s C).
auto with coc core arith datatypes.
Qed.

  Hint Resolve iki_K: coc.

  Definition int_eq_can : intP -> intP -> Prop := Tfor_all2 _ _ ik_eq.
  Definition int_inv (i : intP) := int_eq_can i i.

  Hint Unfold int_eq_can int_inv: coc.

  Lemma ins_int_inv :
   forall (e f : intP) (k : nat) (y : Int_K),
   TIns _ y k e f -> int_inv f -> int_inv e.
unfold int_inv, int_eq_can in |- *.
simple induction 1; intros; auto with coc core arith datatypes.
inversion_clear H0; auto with coc core arith datatypes.

inversion_clear H2; auto with coc core arith datatypes.
Qed.

  Lemma int_inv_int_eq_can : forall i : intP, int_inv i -> int_eq_can i i.
auto with coc core arith datatypes.
Qed.

  Hint Resolve int_inv_int_eq_can: coc.

  Lemma int_eq_can_cls :
   forall i i' : intP, int_eq_can i i' -> cls_of_int i = cls_of_int i'.
unfold cls_of_int in |- *.
simple induction 1; simpl in |- *; intros; auto with coc core arith datatypes.
inversion_clear H0; simpl in |- *; intros; elim H2;
 auto with coc core arith datatypes.
Qed.

  Fixpoint int_typ (T : term) : intP -> forall s : skel, Can s :=
    fun (ip : intP) (s : skel) =>
    match T with
    | Srt _ => default_can s
    | Ref n => coerce_CR s (Tnth_def _ (iK PROP sn) ip n)
    | Abs A t =>
        match cl_term A (cls_of_int ip) with
        | Knd _ =>
            match s as x return (Can x) with
            | PROD s1 s2 =>
                fun C : Can s1 => int_typ t (TCs _ (iK s1 C) ip) s2
            | PROP => default_can PROP
            end
        | Typ _ => int_typ t (def_cons A ip) s
        | _ => default_can s
        end
    | App u v =>
        match cl_term v (cls_of_int ip) with
        | Trm => int_typ u ip s
        | Typ sv => int_typ u ip (PROD sv s) (int_typ v ip sv)
        | _ => default_can s
        end
    | Prod A B =>
        match s as x return (Can x) with
        | PROP =>
            let s := cv_skel (cl_term A (cls_of_int ip)) in
            Pi s (int_typ A ip PROP)
              (fun C => int_typ B (int_cons A ip s C) PROP)
        | PROD s1 s2 => default_can (PROD s1 s2)
        end
    end.