(** * Push-Button Synthesis of Saturated Solinas *)
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.MSets.MSetPositive.
Require Import Coq.Lists.List.
Require Import Coq.QArith.QArith_base Coq.QArith.Qround.
Require Import Coq.derive.Derive.
Require Import Crypto.Util.ErrorT.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ListUtil.FoldBool.
Require Import Crypto.Util.Strings.Decimal.
Require Import Crypto.Util.Strings.Show.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Zselect.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Tactics.HasBody.
Require Import Crypto.Util.Tactics.Head.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Rewriter.Language.Wf.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.Stringification.Language.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.Saturated.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Require Import Crypto.PushButtonSynthesis.Primitives.
Require Import Crypto.PushButtonSynthesis.SaturatedSolinasReificationCache.
Require Import Crypto.Assembly.Equivalence.
Import ListNotations.
Local Open Scope Z_scope. Local Open Scope list_scope. Local Open Scope bool_scope.

Import
  Language.Wf.Compilers
  Language.Compilers
  AbstractInterpretation.Compilers
  Stringification.Language.Compilers.
Import Compilers.API.

Import COperationSpecifications.Primitives.
Import COperationSpecifications.Solinas.
Import COperationSpecifications.SaturatedSolinas.

Import Associational Positional.

Local Coercion Z.of_nat : nat >-> Z.
Local Coercion QArith_base.inject_Z : Z >-> Q.
Local Coercion Z.pos : positive >-> Z.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Local Opaque reified_mul_gen. (* needed for making [autorewrite] not take a very long time *)
(* needed for making [autorewrite] with [Set Keyed Unification] fast *)
Local Opaque expr.Interp.

Section __.
  Context {output_language_api : ToString.OutputLanguageAPI}
          {language_naming_conventions : language_naming_conventions_opt}
          {package_namev : package_name_opt}
          {class_namev : class_name_opt}
          {static : static_opt}
          {internal_static : internal_static_opt}
          {low_level_rewriter_method : low_level_rewriter_method_opt}
          {only_signed : only_signed_opt}
          {no_select : no_select_opt}
          {use_mul_for_cmovznz : use_mul_for_cmovznz_opt}
          {emit_primitives : emit_primitives_opt}
          {should_split_mul : should_split_mul_opt}
          {should_split_multiret : should_split_multiret_opt}
          {unfold_value_barrier : unfold_value_barrier_opt}
          {assembly_hints_lines : assembly_hints_lines_opt}
          {widen_carry : widen_carry_opt}
          (widen_bytes : widen_bytes_opt := true) (* true, because we don't allow byte-sized things anyway, so we should not expect carries to be widened to byte-size when emitting C code *)
          {assembly_calling_registers : assembly_calling_registers_opt}
          {assembly_stack_size : assembly_stack_size_opt}
          {error_on_unused_assembly_functions : error_on_unused_assembly_functions_opt}
          {assembly_output_first : assembly_output_first_opt}
          {assembly_argument_registers_left_to_right : assembly_argument_registers_left_to_right_opt}
          (s : Z)
          (c : list (Z * Z))
          (machine_wordsize : Z).

  Local Existing Instance widen_bytes.

  (* We include [0], so that even after bounds relaxation, we can
       notice where the constant 0s are, and remove them. *)
  Definition possible_values_of_machine_wordsize
    := prefix_with_carry [machine_wordsize].

  Definition n : nat := Z.to_nat (Qceiling (Z.log2_up s / machine_wordsize)).
  Definition m := s - Associational.eval c.
  (* Number of reductions is calculated as follows :
         Let i be the highest limb index of c. Then, each reduction
         decreases the number of extra limbs by (n-i-1). (The -1 comes
         from possibly having an extra high partial product at the end
         of a reduction.) So, to go from the n extra limbs we have
         post-multiplication down to 0, we need ceil (n / (n - i - 1))
         reductions.  In some cases. however, [n - i <= 1], and in
         this case, we do [n] reductions (is this enough?). *)
  Definition nreductions : nat :=
    let i := fold_right Z.max 0 (map (fun t => Z.log2 (fst t) / machine_wordsize) c) in
    if Z.of_nat n - i <=? 1
    then n
    else Z.to_nat (Qceiling (Z.of_nat n / (Z.of_nat n - i - 1))).
  Let possible_values := possible_values_of_machine_wordsize.
  Definition bound := Some r[0 ~> (2^machine_wordsize - 1)]%zrange.
  Definition boundsn : list (ZRange.type.option.interp base.type.Z)
    := repeat bound n.

  Local Instance no_select_size : no_select_size_opt := no_select_size_of_no_select machine_wordsize.
  Local Instance split_mul_to : split_mul_to_opt := split_mul_to_of_should_split_mul machine_wordsize possible_values.
  Local Instance split_multiret_to : split_multiret_to_opt := split_multiret_to_of_should_split_multiret machine_wordsize possible_values.

  (** Note: If you change the name or type signature of this
        function, you will need to update the code in CLI.v *)
  Definition check_args {T} (res : Pipeline.ErrorT T)
    : Pipeline.ErrorT T
    := fold_right
         (fun '(b, e) k => if b:bool then Error e else k)
         res
         [((negb (0 <? s - Associational.eval c))%Z, Pipeline.Value_not_ltZ "s - Associational.eval c ≤ 0" 0 (s - Associational.eval c));
            ((s =? 0)%Z, Pipeline.Values_not_provably_distinctZ "s ≠ 0" s 0);
            ((n =? 0)%nat, Pipeline.Values_not_provably_distinctZ "n ≠ 0" n 0);
            ((negb (0 <? machine_wordsize)), Pipeline.Value_not_ltZ "0 < machine_wordsize" 0 machine_wordsize)].

  Local Ltac prepare_use_curve_good _ :=
    let curve_good := lazymatch goal with | curve_good : check_args _ = Success _ |- _ => curve_good end in
    clear -curve_good;
    cbv [check_args] in curve_good |- *;
    cbn [fold_right] in curve_good |- *;
    repeat first [ match goal with
                   | [ H : context[match ?b with true => _ | false => _ end ] |- _ ] => destruct b eqn:?
                   end
                 | discriminate
                 | progress Reflect.reflect_hyps
                 | assumption
                 | apply conj
                 | progress destruct_head'_and ].

  Local Ltac use_curve_good_t :=
    repeat first [ assumption
                 | progress rewrite ?map_length, ?Z.mul_0_r, ?Pos.mul_1_r, ?Z.mul_1_r in *
                 | reflexivity
                 | lia
                 | rewrite expr.interp_reify_list, ?map_map
                 | rewrite map_ext with (g:=id), map_id
                 | progress distr_length
                 | progress cbv [Qceiling Qfloor Qopp Qdiv Qplus inject_Z Qmult Qinv] in *
                 | progress cbv [Qle] in *
                 | progress cbn -[reify_list] in *
                 | progress intros
                 | solve [ auto ] ].

  Context (curve_good : check_args (Success tt) = Success tt).

  Lemma use_curve_good
    : 0 < s - Associational.eval c
      /\ s - Associational.eval c <> 0
      /\ s <> 0
      /\ 0 < machine_wordsize
      /\ n <> 0%nat.
  Proof using curve_good.
    prepare_use_curve_good ().
    { use_curve_good_t. }
  Qed.

  Local Notation weightf := (weight machine_wordsize 1).
  Local Notation evalf := (eval weightf n).
  Local Notation notations_for_docstring
    := (CorrectnessStringification.dyn_context.cons
          weightf "weight"
          (CorrectnessStringification.dyn_context.cons
             evalf "eval"
             CorrectnessStringification.dyn_context.nil))%string.
  Local Notation "'docstring_with_summary_from_lemma!' summary correctness"
    := (docstring_with_summary_from_lemma_with_ctx!
          notations_for_docstring
          summary
          correctness)
         (only parsing, at level 10, summary at next level, correctness at next level).

  Definition mul
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         None (* fancy *)
         possible_values
         (reified_mul_gen
            @ GallinaReify.Reify s @ GallinaReify.Reify c @ GallinaReify.Reify machine_wordsize @ GallinaReify.Reify n @ GallinaReify.Reify nreductions)
         (Some boundsn, (Some boundsn, tt))
         (Some boundsn, None (* Should be: Some r[0~>0]%zrange, but bounds analysis is not good enough *) ).

  Definition smul (prefix : string)
    : string * (Pipeline.ErrorT (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString
          machine_wordsize prefix "mul" mul
          (docstring_with_summary_from_lemma!
             (fun fname : string => ["The function " ++ fname ++ " multiplies two field elements."]%string)
             (mul_correct weightf n m boundsn)).

  Local Ltac solve_extra_bounds_side_conditions :=
    cbn [lower upper fst snd] in *; Bool.split_andb; Z.ltb_to_lt; lia.

  Hint Rewrite
       (fun pf => @Rows.eval_mulmod (weight machine_wordsize 1) (@wprops _ _ pf))
       using solve [ auto with zarith | congruence | solve_extra_bounds_side_conditions ] : push_eval.
  Hint Unfold mulmod : push_eval.

  Local Ltac prove_correctness _ := Primitives.prove_correctness use_curve_good.

  Lemma mul_correct res
        (Hres : mul = Success res)
    : mul_correct (weight machine_wordsize 1) n m boundsn (Interp res).
  Proof using curve_good. prove_correctness (). Qed.

  Lemma Wf_mul res (Hres : mul = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Section for_stringification.
    Local Open Scope string_scope.
    Local Open Scope list_scope.

    Definition known_functions
      := [("mul", wrap_s smul)].

    Definition valid_names : string := Eval compute in String.concat ", " (List.map (@fst _ _) known_functions).

    (** Note: If you change the name or type signature of this
          function, you will need to update the code in CLI.v *)
    Definition Synthesize (comment_header : list string) (function_name_prefix : string) (requests : list string)
      : list (synthesis_output_kind * string * Pipeline.ErrorT (list string))
      := Primitives.Synthesize
           machine_wordsize valid_names known_functions (fun _ => nil)
           check_args
           ((ToString.comment_file_header_block
               (comment_header
                  ++ ["";
                     "Computed values:";
                     "# reductions = " ++ show false nreductions]%string)))
           function_name_prefix requests.
  End for_stringification.
End __.

Module Export Hints.
  Hint Opaque
       mul
  : wf_op_cache.
  Hint Immediate
       Wf_mul
  : wf_op_cache.
End Hints.


Require Import Syntax TypeAlgo.

Theorem algo_values_all_effect:
    forall C v T D G max_rho max_X max_rho' max_X',
        welltyped_algo G max_rho max_X (e_Thread (t_Value v)) T (EffectIntro D D) C max_rho' max_X' ->
        forall D',
        welltyped_algo G max_rho max_X (e_Thread (t_Value v)) T (EffectIntro D' D') C max_rho' max_X'.
Proof.


From iris.proofmode Require Import tactics.
From iris.algebra Require Import gset coPset.
From iris.base_logic.lib Require Export invariants.
From iris Require Import options.
Import uPred.

(* Non-atomic ("thread-local") invariants. *)

Definition na_inv_pool_name := gname.

Class na_invG Σ :=
  na_inv_inG :> inG Σ (prodR coPset_disjR (gset_disjR positive)).
Definition na_invΣ : gFunctors :=
  #[ GFunctor (constRF (prodR coPset_disjR (gset_disjR positive))) ].
Instance subG_na_invG {Σ} : subG na_invΣ Σ → na_invG Σ.
Proof. solve_inG. Qed.

Section defs.
  Context `{!invG Σ, !na_invG Σ}.

  Definition na_own (p : na_inv_pool_name) (E : coPset) : iProp Σ :=
    own p (CoPset E, GSet ∅).

  Definition na_inv (p : na_inv_pool_name) (N : namespace) (P : iProp Σ) : iProp Σ :=
    (∃ i, ⌜i ∈ (↑N:coPset)⌝ ∧
          inv N (P ∗ own p (CoPset ∅, GSet {[i]}) ∨ na_own p {[i]}))%I.
End defs.

Instance: Params (@na_inv) 3 := {}.
Typeclasses Opaque na_own na_inv.

Section proofs.
  Context `{!invG Σ, !na_invG Σ}.

  Global Instance na_own_timeless p E : Timeless (na_own p E).
  Proof. rewrite /na_own; apply _. Qed.

  Global Instance na_inv_ne p N : NonExpansive (na_inv p N).
  Proof. rewrite /na_inv. solve_proper. Qed.
  Global Instance na_inv_proper p N : Proper ((≡) ==> (≡)) (na_inv p N).
  Proof. apply (ne_proper _). Qed.

  Global Instance na_inv_persistent p N P : Persistent (na_inv p N P).
  Proof. rewrite /na_inv; apply _. Qed.

  Lemma na_inv_iff p N P Q : na_inv p N P -∗ ▷ □ (P ↔ Q) -∗ na_inv p N Q.
  Proof.
    iIntros "HI #HPQ". rewrite /na_inv. iDestruct "HI" as (i ?) "HI".
    iExists i. iSplit; first done. iApply (inv_iff with "HI").
    iIntros "!> !>".
    iSplit; iIntros "[[? Ho]|$]"; iLeft; iFrame "Ho"; by iApply "HPQ".
  Qed.

  Lemma na_alloc : ⊢ |==> ∃ p, na_own p ⊤.
  Proof. by apply own_alloc. Qed.

  Lemma na_own_disjoint p E1 E2 : na_own p E1 -∗ na_own p E2 -∗ ⌜E1 ## E2⌝.
  Proof.
    apply wand_intro_r.
    rewrite /na_own -own_op own_valid -coPset_disj_valid_op. by iIntros ([? _]).
  Qed.

  Lemma na_own_union p E1 E2 :
    E1 ## E2 → na_own p (E1 ∪ E2) ⊣⊢ na_own p E1 ∗ na_own p E2.
  Proof.
    intros ?. by rewrite /na_own -own_op -pair_op left_id coPset_disj_union.
  Qed.

  Lemma na_own_acc E2 E1 tid :
    E2 ⊆ E1 → na_own tid E1 -∗ na_own tid E2 ∗ (na_own tid E2 -∗ na_own tid E1).
  Proof.
    intros HF. assert (E1 = E2 ∪ (E1 ∖ E2)) as -> by exact: union_difference_L.
    rewrite na_own_union; last by set_solver+. iIntros "[$ $]". auto.
  Qed.

  Lemma na_inv_alloc p E N P : ▷ P ={E}=∗ na_inv p N P.
  Proof.
    iIntros "HP".
    iMod (own_unit (prodUR coPset_disjUR (gset_disjUR positive)) p) as "Hempty".
    iMod (own_updateP with "Hempty") as ([m1 m2]) "[Hm Hown]".
    { apply prod_updateP'. apply cmra_updateP_id, (reflexivity (R:=eq)).
      apply (gset_disj_alloc_empty_updateP_strong' (λ i, i ∈ (↑N:coPset))).
      intros Ef. exists (coPpick (↑ N ∖ gset_to_coPset Ef)).
      rewrite -elem_of_gset_to_coPset comm -elem_of_difference.
      apply coPpick_elem_of=> Hfin.
      eapply nclose_infinite, (difference_finite_inv _ _), Hfin.
      apply gset_to_coPset_finite. }
    simpl. iDestruct "Hm" as %(<- & i & -> & ?).
    rewrite /na_inv.
    iMod (inv_alloc N with "[-]"); last (iModIntro; iExists i; eauto).
    iNext. iLeft. by iFrame.
  Qed.

  Lemma na_inv_acc p E F N P :
    ↑N ⊆ E → ↑N ⊆ F →
    na_inv p N P -∗ na_own p F ={E}=∗ ▷ P ∗ na_own p (F∖↑N) ∗
                       (▷ P ∗ na_own p (F∖↑N) ={E}=∗ na_own p F).
  Proof.
    rewrite /na_inv. iIntros (??) "#Hnainv Htoks".
    iDestruct "Hnainv" as (i) "[% Hinv]".
    rewrite [F as X in na_own p X](union_difference_L (↑N) F) //.
    rewrite [X in (X ∪ _)](union_difference_L {[i]} (↑N)) ?na_own_union; [|set_solver..].
    iDestruct "Htoks" as "[[Htoki $] $]".
    iInv "Hinv" as "[[$ >Hdis]|>Htoki2]" "Hclose".
    - iMod ("Hclose" with "[Htoki]") as "_"; first auto.
      iIntros "!> [HP $]".
      iInv N as "[[_ >Hdis2]|>Hitok]".
      + iDestruct (own_valid_2 with "Hdis Hdis2") as %[_ Hval%gset_disj_valid_op].
        set_solver.
      + iSplitR "Hitok"; last by iFrame. eauto with iFrame.
    - iDestruct (na_own_disjoint with "Htoki Htoki2") as %?. set_solver.
  Qed.

  Global Instance into_inv_na p N P : IntoInv (na_inv p N P) N := {}.

  Global Instance into_acc_na p F E N P :
    IntoAcc (X:=unit) (na_inv p N P)
            (↑N ⊆ E ∧ ↑N ⊆ F) (na_own p F) (fupd E E) (fupd E E)
            (λ _, ▷ P ∗ na_own p (F∖↑N))%I (λ _, ▷ P ∗ na_own p (F∖↑N))%I
              (λ _, Some (na_own p F))%I.
  Proof.
    rewrite /IntoAcc /accessor. iIntros ((?&?)) "#Hinv Hown".
    rewrite exist_unit -assoc /=.
    iApply (na_inv_acc with "Hinv"); done.
  Qed.
End proofs.


(**
   Version très simplifiée des idée de: "Java bytecode verification: algorithms
   and formalizations", Xavier Leroy (Journal of Automated Reasoning,
   30(3-4):235-269, 2003).

   Dont voici l'abstract:

   "Bytecode verification is a crucial security component for Java applets, on
   the Web and on embedded devices such as smart cards. This paper reviews the
   various bytecode verification algorithms that have been proposed, recasts
   them in a common framework of dataflow analysis, and surveys the use of proof
   assistants to specify bytecode verification and prove its correctness."

 *)

(* Coq écrira de préférence la syntaxe [foo.(bar)] plutôt que [(bar
   foo)], pour les champs (bar) de records (foo). *)
Set Printing Projections.

Require Omega.

Require Import OrderedType OrderedTypeEx OrderedTypeAlt DecidableType DecidableTypeEx.
From bcv Require Import LibHypsNaming heritage vmtype vmdefinition.

(** * Valeurs manipulée par la machine défensive,

   Ce module servira à instancier VMDefinition plus bas.
   La définition des types, classes et instruction est fixée dans [vmtype]. *)

Module DefVal <: VMVal.

  Inductive DVal:Set :=
  | Vint (i:nat)
  | Vref (clrf:class_id * heap_idx) (** nom de classe * adresse dans le tas *)
  | Vrefnull
  | Error
  | NonInit.

  Definition Val := DVal.

(****)
 Definition build_flds: ClasseDef -> (Dico.t Val) :=
    Dico.map
      (fun t:VMType =>
         match t with
         | Tint => Vint 0
         | Tref id => Vref (id, 0) (** null = 0 *)
         | Object => Vrefnull (** null = 0 *)
         | Top => Vrefnull (** Should never happen *)
         | Trefnull => Vrefnull (** Should never happen *)
         end).

  (** Calcul du type d'une valeur défensive. *)
  Definition v2t (v:Val): VMType :=
    match v with
      | Vint i => Tint
      | Vref (clid,_) => Tref clid
      | Vrefnull => Trefnull
      | Error => Top
      | NonInit => Top
    end.

  Lemma val_eq_dec : forall v1 v2:Val, {v1=v2}+{v1<>v2}.
  Proof.
    intros v1 v2.
    decide equality.
    decide equality.
    decide equality.
    decide equality.
    decide equality.
  Qed.

End DefVal.

Module D (H:Herit).

(** États défensifs. *)
  Module Def := VMDefinition(DefVal)(H).
  Import DefVal.
  Include Def.
  Ltac rename_dvm h th := fail.

  (* Hypothesis renaming stuff from other files + current file.
     DO NOT REDEFINE IN THIS FILE. Redefine rename_dvm instead. *)
  Ltac rename_hyp h th ::=
    match th with
    | _ => (rename_dvm h th) (* redefine this tactic at will to enrich renaming*)
    | _ => (Def.rename_vmdef h th) (* renaming from Def *)
    | _ => (LibHypsNaming.rename_hyp_neg h th) (* basic generic renaming *)
    end.

  Function new (clid:class_id) (heap:Heap) : option (heap_idx * Heap) :=
    match Dico.find clid allcl with
    | None => None (** Classe inconnue *)
    | Some cldef =>
      let flds:Obj := {| objclass := clid; objfields := build_flds cldef |} in
      let newhpidx: nat := maxkey heap in
      Some((S newhpidx), Dico.add (S newhpidx) flds heap)
    end.

  (** test *)
  (*
    Definition obj1:Obj := {| objclass:=1; objfields:=Dico.empty _|}.
    Definition heap1:Heap := Dico.empty _ .
    Definition heap2:Heap := Dico.add 1 obj1 heap1.
    Definition heap3:Heap := Dico.add 2 obj1 heap2.
    Eval vm_compute in (maxkey heap3).
    Eval vm_compute in (maxkey heap2). *)
  (* fin test *)

  (** * Fonction d'exécution défensive d'*un* bytecode.

     Pas de vérif d'overflow sur la pile d'opérandes. pas de nb
     négatifs, on ne vérifie que le typage et les underflow. *)

   Definition exec_step (s:State): option State :=
    let frm:Frame := s.(frame) in
    let pc: pc_idx := frm.(pc) in
    let instr_opt := Dico.find pc (frm.(mdef).(instrs)) in
    match instr_opt with
    | None => None
    | Some instr =>
      match instr with
      | ret => Some s
      | Iconst i =>
        Some {| framestack := s.(framestack); heap := s.(heap);
                frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                            pc:= pc + 1;
                            stack:= Vint i :: s.(frame).(stack)
                         |}
             |}

      | Iadd =>
        match s.(frame).(stack) with
        | Vint i1 :: Vint i2 :: stack' =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef); regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= Vint (i1+i2) :: stack'
                           |}
               |}
        | nil | _ :: nil => None (** Stack underflow *)
        | _ :: _ => None (**Addition de types autres que int**)
        end

      | Iload ridx =>
        match Dico.find ridx (s.(frame).(regs)) with
        | Some (Vint i) =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef); regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:=Vint i :: s.(frame).(stack)
                           |}
               |}
        |_ => None
       end

      | Rload clid_expected ridx =>
        match Dico.find ridx (s.(frame).(regs)) with
        | Some (Vref (clid_actual, hidx)) => if H.sub clid_actual clid_expected  then
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ;
                              regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= Vref (clid_actual, hidx) :: s.(frame).(stack)
                           |}
               |}
          else
              None
        | _ => None
        end

      | Istore ridx =>
        match s.(frame).(stack) with
        | Vint i :: stack' =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ;
                              regs:= Dico.add ridx (Vint i) (s.(frame).(regs));
                              pc:= pc + 1;
                              stack:= stack'
                           |}
               |}
        | nil => None (** Stack underflow *)
        | _ => None
        end

      | Rstore clid ridx =>
        match s.(frame).(stack) with
          | (Vref (clid_actual, hidx)) :: stack'=> if H.sub clid_actual clid then
            Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ;
                              regs:= Dico.add ridx (Vref (clid_actual, hidx)) (s.(frame).(regs));
                              pc:= pc + 1;
                              stack:= stack'
                           |}
               |}
          else
              None
        | _ => None (** Stack underflow *)
        end

      | Iifle jmp => (** ifeqe *)
        match s.(frame).(stack) with
        | Vint 0 :: stack' => (** = 0  --> jump *)
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= jmp;
                              stack:= stack'
                           |}
               |}
        | Vint _ :: stack' => (** <> 0  --> pc+1 *)
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= pc+1;
                              stack:= stack'
                           |}
               |}
        | _ => None (** Stack underflow or type error *)
        end
(*
      | Goto jmp =>
        Some {| framestack := s.(framestack); heap := s.(heap);
                frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                            stack:= s.(frame).(stack);
                            pc:= jmp
                         |}
             |}

      | Getfield cl namefld typ => None
      | Putfield cl namefld typ =>
        match s.(frame).(stack) with
        | hpidx :: v :: stack' =>
          match Dico.find hpidx s.(heap) with
          | None => None (** adresse inconnue, objet non alloué *)
          | Some {| objclass:= objcl; objfields:= flds |}=>
            let newflds := {| objclass:= objcl;
                              objfields:=Dico.add namefld v flds |} in
            let newheap := Dico.add hpidx newflds s.(heap) in
            Some {| framestack := s.(framestack);
                    heap := newheap;
                    frame := {| mdef:=s.(frame).(mdef) ;
                                regs:= s.(frame).(regs);
                                pc:= pc+1;
                                stack:= stack'
                             |}
                 |}
          end
        | nil | _ :: nil => None (** Stack underflow *)
        end

      | New clid =>
        match new clid s.(heap) with
        | None => None (** Classe inconnue *)
        | Some (newobj,newhp) =>
          Some {| framestack := s.(framestack); heap := newhp;
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              stack:= newobj :: s.(frame).(stack);
                              pc:= pc+1
                           |}
               |}

        end
      end
    end.
*)
 | _ => None
  end
end.

  Functional Scheme exec_step_ind := Induction for exec_step Sort Prop.

  (** * Tests *)

  Notation "k --> i , d" := (Dico.add k i d) (at level 55, right associativity).

  Definition prog:MethodDef :=
    {| instrs := (0 --> Iload 1 ,
                  1 --> Istore 2 ,
                  2 --> ret ,
                  Dico.empty ) ;
       argstype :=( Tint :: Tint:: nil);
       restype := Tint |}.

  Definition startstate:State :=
    {|
      framestack := nil;
      heap := Dico.empty;
      frame := {|
                mdef:= prog ;
                regs:= (0 --> Vint 32 , 1-->Vint 11, Dico.empty );
                pc:= 0;
                stack:= nil
              |}
    |}.

  Fixpoint exec_n (s : State) (n:nat) {struct n}: option State :=
    match n with
    | 0 => Some s
    | S n' =>
      match exec_step s with
      | None => None
      | Some s' => exec_n s' n'
      end
    end.
  (*
    Eval simpl in exec_n startstate 1.
    Eval simpl in exec_n startstate 2.
    Eval simpl in exec_n startstate 5.
   *)
  (* Eval simpl in exec_n (fun x y => false) (Dico.empty _) startstate 2. *)

  (** Exemple de preuve très simple sur la fonction d'exécution: la
  pile (hormis la méthode en cours d'exécution) ne change pas au cours
  de exec_step. *)

  Lemma essai : forall s x,
      exec_step s = Some x ->
      x.(framestack) = s.(framestack).
  Proof.
    intros s.
    functional induction exec_step s;intros ;simpl;
      try solve [discriminate | inversion H; subst;simpl;reflexivity] .
  Qed.

End D.