(** * Notation and Pretty printing.

Programs are essentially just values of type [code] and one can
construct these objects by applying the appropriate
constructors. Often these constructors are designed so that the
underlying program construct is _correct by construction_ --- for
example array indexing requires a proof that the index is smaller than
the array bound. This is achieved by there being additional parameters
to the constructor which are proofs of safety.

Creating such objects explicitly by applying constructors can be
painful. This module gives a set of Notations that makes the surface
syntax of these code values palatable to the user.

*)

Require Import NArith.
Require Import Nat.
Require Import Verse.Ast.
Require Import Verse.Language.Types.
Require Import Verse.TypeSystem.
Import List.ListNotations.
Require        Vector.
Import         Vector.VectorNotations.
Require Import Verse.Nibble.

Set Implicit Arguments.

(* DEVELOPER notes.

We can avoid all type classes and move over to canonical structures if
that is what we are going to use in the rest of the code

*)

(** * Types embeddable as expressions

For program variables [v : VariableT] and a verse type [ty] recall
that [expr v ty] type captures expressions in verse. We would like to
consider other types like, [nat] constants, program variables [x : v ty]
etc, to be considered as verse expressions. We do this in two stages.

- We have the class [EXPR] that declares instances which can be
  converted to [expr]. Some of the instances of this class are [v ty],
  [nat]'s and [expr]'s themselves.

- We use infix operators like [+] etc to combine instances of [EXPR]
  to get new expressions. Thus we can embed many of the common types
  as expressions.

*)

Section Embedding.
  Variable v  : Variables.U verse_type_system.
  Variable ty : type direct.

  (** Class of all types [t] that can be converted into expressions *)
  Class EXPR  t := toExpr  : t -> expr v (existT _ _ ty).

  (** *** Instances of [EXPR]
   *)

  Global Instance expr_to_expr   : EXPR (expr  v (existT _ _ ty))  := @id _.
  Global Instance v_to_exp       : EXPR (v (existT _ _ ty))        := fun x => valueOf (var x).
  Global Instance lexp_to_exp    : EXPR (lexpr v (existT _ _ ty))  := valueOf (ty := existT _ _ ty).
  Global Instance const_to_expr  : EXPR (const ty)    := cval (ty:=ty).
  Global Instance nat_to_exp     : EXPR nat := fun n => cval (natToConst ty n).

  Global Instance N_to_exp       : EXPR N := fun n => cval (NToConst ty n).

  (** Class similar to [EXPR] but creates l-expressions *)
  Class LEXPR t := toLexpr : t -> lexpr v (existT _ _ ty).

  Global Instance lexpr_to_lexpr : LEXPR (lexpr v (existT _ _ ty)) := @id _.
  Global Instance v_to_lexp      : LEXPR (v (existT _ _ ty))       := var (ty:=ty).

  (** We now define helper functions that "lift" verse operators to
      work with instances of [EXPR].  *)
  Section Operators.

    Variable bop : operator verse_type_system ty 2.
    Variable uop : operator verse_type_system ty 1.

    Variable t      : Type.
    Variable lhs    : t.
    Variable class  : LEXPR t.

    Variable t1 t2 : Type.
    Variable e1 : t1.
    Variable e2 : t2.
    Variable class1 : EXPR t1.
    Variable class2 : EXPR t2.

    Definition assignStmt : statement v
      := existT _  _ (assign  (toLexpr lhs)  (toExpr e1)).

     Definition moveStmt (x : v (existT _ _ ty)) : statement v
      := existT _ _ (Ast.moveTo (toLexpr lhs) x).

    (** Applies the binary operator [o] to two values [e1] and [e2]
        both of which are convertable to expressions.  *)
    Definition binOpApp
      := binOp bop (toExpr e1) (toExpr e2).

    (** Update instruction which uses an input binary operator to
        update the l-expression [x].  *)

    Definition binOpUpdate : statement v
      := existT _ _ (binopUpdate (toLexpr lhs) bop (toExpr e1)).

    (** Applies the unary operator [o] to the value [e] that is
        convertible to expression. *)
    Definition uniOpApp
    :=  uniOp uop (toExpr e1).

    (** Update a given lexpression using the given unary operator
        [o]. *)
    Definition uniOpUpdate : statement v
      := existT _ _ (uniopUpdate (toLexpr lhs) uop).

    End Operators.
End Embedding.

Instance bvec_to_expr v sz : EXPR v (word sz) (BWord sz)
  := { toExpr := fun v : const (word sz) => cval v }.
Instance nibbles_to_exp v sz  : EXPR v (word sz) (Nibble.bytes (2^sz))
  := { toExpr := fun nibs => toExpr (toBv nibs) }.

Arguments assignStmt [v ty t] lhs [class t1] e1 {class1}.
Arguments moveStmt [v ty t] lhs [class] x.
Arguments binOpApp [v ty] bop  [t1 t2] e1 e2  {class1 class2}.
Arguments binOpUpdate [v ty] bop [t] lhs [class] [t1] e1 {class1} .
Arguments uniOpApp [v ty] uop  [t1] e1 {class1}.
Arguments uniOpUpdate [v ty] uop [t] lhs {class}.

(** * Indexing types.

Often we want to index elements withing a bound. The class [INDEXING]
captures such types. Array variables are usual objects but we have an
instance for generic indexing functions. The indexing functions
give

*)

Class INDEXING (Ix : Set)(result : Type) t
  := idx : t -> Ix  -> result.

Instance indexing_by_function b t : INDEXING {i | i < b} t (forall i : nat, i < b -> t)
  := fun f ix => match ix with
              | @exist _ _ i pf => f i pf
              end.

Instance array_indexing v ty b e : INDEXING {i | i < b}
                                            (lexpr v (existT _ _ ty))
                                            (v (existT _ _ (array b e ty)))
  := fun a ix =>  deref a ix.

Instance vector_indexing A b : INDEXING {i | i < b} A (Vector.t A b) :=
  fun va ix => Vector.nth_order va (proj2_sig ix).
(*
Instance var_array (v : Variables.U verse_type_system) ty b : INDEXING {i | i < b}
                                                                       (v ty)
                                                                       (Vector.t (v ty) b)
  := fun va ix => Vector.nth_order va (proj2_sig ix).
*)
Declare Scope verse_scope.
Delimit Scope verse_scope with verse.

Class AST_maps (A B : Type) := { CODE : A -> list B }.

#[export] Instance code_id (v : VariableT)
  : AST_maps (code v) (statement (ts := verse_type_system) v)
  := { CODE := id }.

#[export] Instance code_repeat (v : VariableT)
  : AST_maps (code v) (repeated (code (ts := verse_type_system) v))
  := { CODE := fun C => [ repeat 1 C ]%list }.

Declare Custom Entry verse.
(* Notation "'[code|' e  '|]'" := e (e custom verse). *)
Notation "A [ N ] " := (idx A (@exist _ _ N%nat _)) (in custom verse at level 29, N constr).
Notation "[verse| e |]" := e (e custom verse).
Notation "[code| x ; .. ; y |]":= (CODE (cons x .. (cons y nil) ..)) (x custom verse, y custom verse,
                                      format "[code| '[    '  '//' x ; '//' .. ; '//' y '//' ']' '//' '|]'"
                                    ).
Notation "x" := x (in custom verse at level 0, x global).
Notation "( x )" := x  (in custom verse at level 0).
Notation "` x `" := x  (in custom verse at level 0, x constr, format "` x `").

(** Notation for operators.

We more or less follow the C convention for operator and their
precedence except for the operator [^] which has a predefined
precedence in Coq.

*)

Notation "~ E"      := (uniOpApp bitComp E)      (in custom verse at level 30, right associativity).

Infix "*"           := (binOpApp mul)            (in custom verse at level 40, left associativity).
Infix "/"           := (binOpApp quot)           (in custom verse at level 40, left associativity).
Infix "%"           := (binOpApp rem)            (in custom verse at level 40, left associativity).

Infix "+"           := (binOpApp plus)           (in custom verse at level 50, left associativity).
Infix "-"           := (binOpApp minus)          (in custom verse at level 50, left associativity).

Notation "E  <<  N" := (uniOpApp (shiftL N) E)   (in custom verse at level 54, left associativity).
Notation "E  ≪  N" := (uniOpApp (shiftL N) E)   (in custom verse at level 54, left associativity).

Notation "E  >>  N" := (uniOpApp (shiftR N) E)   (in custom verse at level 54, left associativity).
Notation "E  ≫  N" := (uniOpApp (shiftR N) E)   (in custom verse at level 54, left associativity).

Notation "E <<<  N" := (uniOpApp (rotL N)   E)   (in custom verse at level 54, left associativity).
Notation "E ⋘  N" := (uniOpApp (rotL N)   E)   (in custom verse at level 54, left associativity).

Notation "E >>>  N" := (uniOpApp (rotR N)   E)   (in custom verse at level 54, left associativity).
Notation "E ⋙  N" := (uniOpApp (rotR N)   E)   (in custom verse at level 54, left associativity).

Infix "&"         := (binOpApp bitAnd)         (in custom verse at level 56, left associativity).
Infix "⊕"         := (binOpApp bitXor)         (in custom verse at level 57, left associativity).
Infix "^"         := (binOpApp bitXor)
                         (in custom verse at level 57, left associativity, only parsing).
Infix "|"         := (binOpApp bitOr)          (in custom verse at level 59, left associativity).

Infix ":="  := assignStmt           (in custom verse at level 70).
Infix "<-"   := moveStmt             (in custom verse at level 70).
Infix "+="  := (binOpUpdate plus)   (in custom verse at level 70).
Infix "-="  := (binOpUpdate minus ) (in custom verse at level 70).
Infix "*="  := (binOpUpdate mul   ) (in custom verse at level 70).
Infix "/="  := (binOpUpdate quot  ) (in custom verse at level 70).
Infix "%="  := (binOpUpdate rem   ) (in custom verse at level 70).
Infix "|="  := (binOpUpdate bitOr ) (in custom verse at level 70).
Infix "&="  := (binOpUpdate bitAnd) (in custom verse at level 70).
Infix "^="  := (binOpUpdate bitXor) (in custom verse at level 70, only parsing).
Infix "⊕="  := (binOpUpdate bitXor) (in custom verse at level 70).

Notation "A <<= N"   := (uniOpUpdate (shiftL N) A)   (in custom verse at level 70).
Notation "A ≪= N"   := (uniOpUpdate (shiftL N) A)   (in custom verse at level 70).

Notation "A >>= N"   := (uniOpUpdate (shiftR N) A)   (in custom verse at level 70).
Notation "A ≫= N"   := (uniOpUpdate (shiftR N) A)   (in custom verse at level 70).

Notation "A <<<= N"  := (uniOpUpdate (rotL N)   A)   (in custom verse at level 70).
Notation "A ⋘= N"  := (uniOpUpdate (rotL N)   A)   (in custom verse at level 70).

Notation "A >>>= N"  := (uniOpUpdate (rotR N)   A)   (in custom verse at level 70).
Notation "A ⋙= N"  := (uniOpUpdate (rotR N)   A)   (in custom verse at level 70).

Notation "'CLOBBER' A" := (existT _ _ (clobber A))   (in custom verse at level 70).
(*
Notation "'MOVE' B 'to' A [ N ]"
  := (existT _ _ (moveTo (deref A (exist _ (N%nat) _)) B)) (in custom verse at level 200, A ident).
 *)

(** * The verse tactic.

The notations clean up the surface syntax but it still leaves routine
but tedious proof burden on to the shoulders of the programmer. We
dispose this of using the tactic called verse. Usually this is the
proof obligations that come out of array indexing. The verse tatic
disposes it of and raises a warning when it cannot (usually these are
out of bound array access).

*)

Ltac  verse_warn :=
  match goal with
  | [ |- ?T ] => idtac "verse: unable to dispose of" T
  end.

Ltac verse_bounds_warn := verse_warn; idtac "possible array index out of bounds".
Ltac verse_modulus_warn := verse_warn; idtac "possible modulo arithmetic over zero".

(* The following doesn't seem to be used any more. Retained to bugfix a later realization. *)
(*Global Hint Resolve PeanoNat.Nat.mod_upper_bound.*)

(* Typically verse throws up bound checks of the kind x < b where b is a symbolic array size

 *)
Require Import Psatz.

Ltac verse_simplify := match goal with
                       | [ H : ?T |- ?T ]     => exact H
                       | [ |- _ <> _ ]        => unfold not; let H := fresh "H" in intro H; inversion H
                       | [ |- ?A mod ?B < ?B ] => apply (PeanoNat.Nat.mod_upper_bound A B)
                       | [ |- _ <= ?T         ] => compute; lia
                       | [ |- _ < ?T         ] => compute; lia
                       end.

Ltac verse_print_mesg :=  match goal with
                          | [ |- _ < _         ]  => verse_bounds_warn
                          | [ |- _ <= _         ] => verse_bounds_warn
                          | [ |- _ < _         ]  => verse_warn; idtac "possible array index out of bound"
                          | [ |- LEXPR _ _ _   ]  => idtac "verse: possible ill-typed operands in instructions"
                          | [ |- EXPR _ _ _    ]  => idtac "verse: possible ill-typed operands in instructions"
                          | _                    => verse_warn; idtac "please handle these obligations yourself"
                          end.

Ltac verse_crush := repeat verse_simplify; verse_print_mesg.
Tactic Notation "verse" uconstr(B) := refine B; verse_crush.


Require Import SpecCert.Formalism.
Require Import SpecCert.Smm.Delta.Invariant.
Require Import SpecCert.x86.

Lemma close_smram_inv:
  preserve_inv CloseSmram.
Proof.
  unfold preserve_inv.
  unfold inv.
  unfold smramc_inv, smram_code_inv.
  intros a a' Hinv Hpre Hpost.
  unfold close_smram_pre in Hpre.
  unfold smramc_is_locked in Hinv.
  unfold smramc_is_unlocked in Hpre.
  destruct Hinv as [Hsmramc Hsmm].
  unfold smramc_is_ro in Hsmramc.
  unfold smramc_is_rw in Hpre.
  rewrite Hpre in Hsmramc; discriminate Hsmramc.
Qed.


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

Require Import SetoidList.
Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import RTLtyping.
Require Import Locations.
Require Import Conventions.
Require Import InterfGraph.
Require Import Coloring.

(** * Correctness of the interference graph *)

(** We show that the interference graph built by [interf_graph]
  is correct in the sense that it contains all conflict edges
  that we need.

  Many boring lemmas on the auxiliary functions used to construct
  the interference graph follow.  The lemmas are of two kinds:
  the ``increasing'' lemmas show that the auxiliary functions only add
  edges to the interference graph, but do not remove existing edges;
  and the ``correct'' lemmas show that the auxiliary functions
  correctly add the edges that we'd like them to add. *)

Lemma graph_incl_refl:
  forall g, graph_incl g g.
Proof.
  intros; split; auto.
Qed.

Lemma add_interf_live_incl_aux:
  forall (filter: reg -> bool) res live g,
  graph_incl g
    (List.fold_left
      (fun g r => if filter r then add_interf r res g else g)
      live g).
Proof.
  induction live; simpl; intros.
  apply graph_incl_refl.
  apply graph_incl_trans with (if filter a then add_interf a res g else g).
  case (filter a).
  apply add_interf_incl.
  apply graph_incl_refl.
  apply IHlive.
Qed.

Lemma add_interf_live_incl:
  forall (filter: reg -> bool) res live g,
  graph_incl g (add_interf_live filter res live g).
Proof.
  intros. unfold add_interf_live. rewrite Regset.fold_1.
  apply add_interf_live_incl_aux.
Qed.

Lemma add_interf_live_correct_aux:
  forall filter res r live,
  InA Regset.E.eq r live -> filter r = true ->
  forall g,
  interfere r res
    (List.fold_left
      (fun g r => if filter r then add_interf r res g else g)
      live g).
Proof.
  induction 1; simpl; intros.
  hnf in H. subst y. rewrite H0.
  generalize (add_interf_live_incl_aux filter res l (add_interf r res g)).
  intros [A B].
  apply A. apply add_interf_correct.
  apply IHInA; auto.
Qed.

Lemma add_interf_live_correct:
  forall filter res live g r,
  Regset.In r live ->
  filter r = true ->
  interfere r res (add_interf_live filter res live g).
Proof.
  intros.  unfold add_interf_live. rewrite Regset.fold_1.
  apply add_interf_live_correct_aux; auto.
  apply Regset.elements_1. auto.
Qed.

Lemma add_interf_op_incl:
  forall res live g,
  graph_incl g (add_interf_op res live g).
Proof.
  intros; unfold add_interf_op. apply add_interf_live_incl.
Qed.

Lemma add_interf_op_correct:
  forall res live g r,
  Regset.In r live ->
  r <> res ->
  interfere r res (add_interf_op res live g).
Proof.
  intros.  unfold add_interf_op.
  apply add_interf_live_correct.
  auto. destruct (Reg.eq r res); congruence.
Qed.

Lemma add_interf_move_incl:
  forall arg res live g,
  graph_incl g (add_interf_move arg res live g).
Proof.
  intros; unfold add_interf_move. apply add_interf_live_incl.
Qed.

Lemma add_interf_move_correct:
  forall arg res live g r,
  Regset.In r live ->
  r <> arg -> r <> res ->
  interfere r res (add_interf_move arg res live g).
Proof.
  intros.  unfold add_interf_move.
  apply add_interf_live_correct.
  auto.
  rewrite dec_eq_false; auto. rewrite dec_eq_false; auto.
Qed.

Lemma add_interf_destroyed_incl_aux_1:
  forall mr live g,
  graph_incl g
    (List.fold_left (fun g r => add_interf_mreg r mr g) live g).
Proof.
  induction live; simpl; intros.
  apply graph_incl_refl.
  apply graph_incl_trans with (add_interf_mreg a mr g).
  apply add_interf_mreg_incl.
  auto.
Qed.

Lemma add_interf_destroyed_incl_aux_2:
  forall mr live g,
  graph_incl g
    (Regset.fold (fun r g => add_interf_mreg r mr g) live g).
Proof.
  intros. rewrite Regset.fold_1. apply add_interf_destroyed_incl_aux_1.
Qed.

Lemma add_interf_destroyed_incl:
  forall live destroyed g,
  graph_incl g (add_interf_destroyed live destroyed g).
Proof.
  induction destroyed; simpl; intros.
  apply graph_incl_refl.
  eapply graph_incl_trans; [idtac|apply IHdestroyed].
  apply add_interf_destroyed_incl_aux_2.
Qed.

Lemma add_interfs_indirect_call_incl:
  forall rfun locs g,
  graph_incl g (add_interfs_indirect_call rfun locs g).
Proof.
  unfold add_interfs_indirect_call. induction locs; simpl; intros.
  apply graph_incl_refl.
  destruct a. eapply graph_incl_trans; [idtac|eauto].
  apply add_interf_mreg_incl.
  auto.
Qed.

Lemma add_interfs_call_incl:
  forall ros locs g,
  graph_incl g (add_interf_call ros locs g).
Proof.
  intros. unfold add_interf_call. destruct ros.
  apply add_interfs_indirect_call_incl.
  apply graph_incl_refl.
Qed.

Lemma interfere_incl:
  forall r1 r2 g1 g2,
  graph_incl g1 g2 ->
  interfere r1 r2 g1 ->
  interfere r1 r2 g2.
Proof.
  unfold graph_incl; intros. elim H; auto.
Qed.

Lemma interfere_mreg_incl:
  forall r1 r2 g1 g2,
  graph_incl g1 g2 ->
  interfere_mreg r1 r2 g1 ->
  interfere_mreg r1 r2 g2.
Proof.
  unfold graph_incl; intros. elim H; auto.
Qed.

Lemma add_interf_destroyed_correct_aux_1:
  forall mr r live,
  InA Regset.E.eq r live ->
  forall g,
  interfere_mreg r mr
    (List.fold_left (fun g r => add_interf_mreg r mr g) live g).
Proof.
  induction 1; simpl; intros.
  hnf in H; subst y. eapply interfere_mreg_incl.
  apply add_interf_destroyed_incl_aux_1.
  apply add_interf_mreg_correct.
  auto.
Qed.

Lemma add_interf_destroyed_correct_aux_2:
  forall mr live g r,
  Regset.In r live ->
  interfere_mreg r mr
    (Regset.fold (fun r g => add_interf_mreg r mr g) live g).
Proof.
  intros. rewrite Regset.fold_1. apply add_interf_destroyed_correct_aux_1.
  apply Regset.elements_1. auto.
Qed.

Lemma add_interf_destroyed_correct:
  forall live destroyed g r mr,
  Regset.In r live ->
  In mr destroyed ->
  interfere_mreg r mr (add_interf_destroyed live destroyed g).
Proof.
  induction destroyed; simpl; intros.
  elim H0.
  elim H0; intros.
  subst a. eapply interfere_mreg_incl.
  apply add_interf_destroyed_incl.
  apply add_interf_destroyed_correct_aux_2; auto.
  apply IHdestroyed; auto.
Qed.

Lemma add_interfs_indirect_call_correct:
  forall rfun mr locs g,
  In (R mr) locs ->
  interfere_mreg rfun mr (add_interfs_indirect_call rfun locs g).
Proof.
  unfold add_interfs_indirect_call. induction locs; simpl; intros.
  elim H.
  destruct H. subst a.
  eapply interfere_mreg_incl.
  apply (add_interfs_indirect_call_incl rfun locs (add_interf_mreg rfun mr g)).
  apply add_interf_mreg_correct.
  auto.
Qed.

Lemma add_interfs_call_correct:
  forall rfun locs g mr,
  In (R mr) locs ->
  interfere_mreg rfun mr (add_interf_call (inl _ rfun) locs g).
Proof.
  intros. unfold add_interf_call.
  apply add_interfs_indirect_call_correct. auto.
Qed.

Lemma add_prefs_call_incl:
  forall args locs g,
  graph_incl g (add_prefs_call args locs g).
Proof.
  induction args; destruct locs; simpl; intros;
  try apply graph_incl_refl.
  destruct l.
  eapply graph_incl_trans; [idtac|eauto].
  apply add_pref_mreg_incl.
  auto.
Qed.

Lemma add_prefs_builtin_incl:
  forall ef args res g,
  graph_incl g (add_prefs_builtin ef args res g).
Proof.
  intros. unfold add_prefs_builtin.
  destruct ef; try apply graph_incl_refl.
  destruct args; try apply graph_incl_refl.
  apply add_pref_incl.
Qed.

Lemma add_interf_entry_incl:
  forall params live g,
  graph_incl g (add_interf_entry params live g).
Proof.
  unfold add_interf_entry; induction params; simpl; intros.
  apply graph_incl_refl.
  eapply graph_incl_trans; [idtac|eauto].
  apply add_interf_op_incl.
Qed.

Lemma add_interf_entry_correct:
  forall params live g r1 r2,
  In r1 params ->
  Regset.In r2 live ->
  r1 <> r2 ->
  interfere r1 r2 (add_interf_entry params live g).
Proof.
  unfold add_interf_entry; induction params; simpl; intros.
  elim H.
  elim H; intro.
  subst a. apply interfere_incl with (add_interf_op r1 live g).
  exact (add_interf_entry_incl _ _ _).
  apply interfere_sym. apply add_interf_op_correct; auto.
  auto.
Qed.

Lemma add_interf_params_incl_aux:
  forall p1 pl g,
  graph_incl g
   (List.fold_left
      (fun g r => if Reg.eq r p1 then g else add_interf r p1 g)
      pl g).
Proof.
  induction pl; simpl; intros.
  apply graph_incl_refl.
  eapply graph_incl_trans; [idtac|eauto].
  case (Reg.eq a p1); intro.
  apply graph_incl_refl. apply add_interf_incl.
Qed.

Lemma add_interf_params_incl:
  forall pl g,
  graph_incl g (add_interf_params pl g).
Proof.
  induction pl; simpl; intros.
  apply graph_incl_refl.
  eapply graph_incl_trans; [idtac|eauto].
  apply add_interf_params_incl_aux.
Qed.

Lemma add_interf_params_correct_aux:
  forall p1 pl g p2,
  In p2 pl ->
  p1 <> p2 ->
  interfere p1 p2
   (List.fold_left
      (fun g r => if Reg.eq r p1 then g else add_interf r p1 g)
      pl g).
Proof.
  induction pl; simpl; intros.
  elim H.
  elim H; intro; clear H.
  subst a. apply interfere_sym. eapply interfere_incl.
  apply add_interf_params_incl_aux.
  case (Reg.eq p2 p1); intro.
  congruence. apply add_interf_correct.
  auto.
Qed.

Lemma add_interf_params_correct:
  forall pl g r1 r2,
  In r1 pl -> In r2 pl -> r1 <> r2 ->
  interfere r1 r2 (add_interf_params pl g).
Proof.
  induction pl; simpl; intros.
  elim H.
  elim H; intro; clear H; elim H0; intro; clear H0.
  congruence.
  subst a. eapply interfere_incl. apply add_interf_params_incl.
  apply add_interf_params_correct_aux; auto.
  subst a. apply interfere_sym.
  eapply interfere_incl. apply add_interf_params_incl.
  apply add_interf_params_correct_aux; auto.
  auto.
Qed.

Lemma add_edges_instr_incl:
  forall sig instr live g,
  graph_incl g (add_edges_instr sig instr live g).
Proof.
  intros. destruct instr; unfold add_edges_instr;
  try apply graph_incl_refl.
  case (Regset.mem r live).
  destruct (is_move_operation o l).
  eapply graph_incl_trans; [idtac|apply add_pref_incl].
  apply add_interf_move_incl.
  apply add_interf_op_incl.
  apply graph_incl_refl.
  case (Regset.mem r live).
  apply add_interf_op_incl.
  apply graph_incl_refl.
  eapply graph_incl_trans; [idtac|apply add_prefs_call_incl].
  eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl].
  eapply graph_incl_trans; [idtac|apply add_interf_op_incl].
  eapply graph_incl_trans; [idtac|apply add_interfs_call_incl].
  apply add_interf_destroyed_incl.
  eapply graph_incl_trans; [idtac|apply add_prefs_call_incl].
  apply add_interfs_call_incl.
  eapply graph_incl_trans. apply add_interf_op_incl. apply add_prefs_builtin_incl.
  destruct o.
  apply add_pref_mreg_incl.
  apply graph_incl_refl.
Qed.

(** The proposition below states that graph [g] contains
  all the conflict edges expected for instruction [instr]. *)

Definition correct_interf_instr
    (live: Regset.t) (instr: instruction) (g: graph) : Prop :=
  match instr with
  | Iop op args res s =>
      match is_move_operation op args with
      | Some arg =>
          forall r,
          Regset.In res live ->
          Regset.In r live ->
          r <> res -> r <> arg -> interfere r res g
      | None =>
          forall r,
          Regset.In res live ->
          Regset.In r live ->
          r <> res -> interfere r res g
      end
  | Iload chunk addr args res s =>
      forall r,
      Regset.In res live ->
      Regset.In r live ->
      r <> res -> interfere r res g
  | Icall sig ros args res s =>
      (forall r mr,
        Regset.In r live ->
        In mr destroyed_at_call_regs ->
        r <> res ->
        interfere_mreg r mr g)
   /\ (forall r,
        Regset.In r live ->
       r <> res -> interfere r res g)
   /\ (match ros with
       | inl rfun => forall mr, In (R mr) (loc_arguments sig) ->
                                interfere_mreg rfun mr g
       | inr idfun => True
       end)
  | Itailcall sig ros args =>
      match ros with
        | inl rfun => forall mr, In (R mr) (loc_arguments sig) ->
                                 interfere_mreg rfun mr g
        | inr idfun => True
      end
  | Ibuiltin ef args res s =>
      forall r,
      Regset.In r live ->
      r <> res -> interfere r res g
  | _ =>
      True
  end.

Lemma correct_interf_instr_incl:
  forall live instr g1 g2,
  graph_incl g1 g2 ->
  correct_interf_instr live instr g1 ->
  correct_interf_instr live instr g2.
Proof.
  intros until g2. intro.
  unfold correct_interf_instr; destruct instr; auto.
  destruct (is_move_operation o l).
  intros. eapply interfere_incl; eauto.
  intros. eapply interfere_incl; eauto.
  intros. eapply interfere_incl; eauto.
  intros [A [B C]].
  split. intros. eapply interfere_mreg_incl; eauto.
  split. intros. eapply interfere_incl; eauto.
  destruct s0; auto. intros. eapply interfere_mreg_incl; eauto.
  destruct s0; auto. intros. eapply interfere_mreg_incl; eauto.
  intros. eapply interfere_incl; eauto.
Qed.

Lemma add_edges_instr_correct:
  forall sig instr live g,
  correct_interf_instr live instr (add_edges_instr sig instr live g).
Proof.
  intros.
  destruct instr; unfold add_edges_instr; unfold correct_interf_instr; auto.
  destruct (is_move_operation o l); intros.
  rewrite Regset.mem_1; auto. eapply interfere_incl.
  apply add_pref_incl. apply add_interf_move_correct; auto.
  rewrite Regset.mem_1; auto. apply add_interf_op_correct; auto.

  intros. rewrite Regset.mem_1; auto. apply add_interf_op_correct; auto.

  (* Icall *)
  set (largs := loc_arguments s).
  set (lres := loc_result s).
  split. intros.
  apply interfere_mreg_incl with
    (add_interf_destroyed (Regset.remove r live) destroyed_at_call_regs g).
  eapply graph_incl_trans; [idtac|apply add_prefs_call_incl].
  eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl].
  eapply graph_incl_trans; [idtac|apply add_interf_op_incl].
  apply add_interfs_call_incl.
  apply add_interf_destroyed_correct; auto.
  apply Regset.remove_2; auto.

  split. intros.
  eapply interfere_incl.
  eapply graph_incl_trans; [idtac|apply add_prefs_call_incl].
  apply add_pref_mreg_incl.
  apply add_interf_op_correct; auto.

  destruct s0; auto; intros.
  eapply interfere_mreg_incl.
  eapply graph_incl_trans; [idtac|apply add_prefs_call_incl].
  eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl].
  apply add_interf_op_incl.
  apply add_interfs_call_correct. auto.

  (* Itailcall *)
  destruct s0; auto; intros.
  eapply interfere_mreg_incl.
  apply add_prefs_call_incl.
  apply add_interfs_call_correct. auto.

  (* Ibuiltin *)
  intros. eapply interfere_incl. apply add_prefs_builtin_incl.
  apply add_interf_op_correct; auto.
Qed.

Lemma add_edges_instrs_correct:
  forall f live pc i,
  f.(fn_code)!pc = Some i ->
  correct_interf_instr live!!pc i (add_edges_instrs f live).
Proof.
  intros f live.
  set (P := fun (c: code) g =>
         forall pc i, c!pc = Some i -> correct_interf_instr live#pc i g).
  set (F := (fun (g : graph) (pc0 : positive) (i0 : instruction) =>
         add_edges_instr (fn_sig f) i0 live # pc0 g)).
  change (P f.(fn_code) (PTree.fold F f.(fn_code) empty_graph)).
  apply PTree_Properties.fold_rec; unfold P; intros.
  apply H0. rewrite H. auto.
  rewrite PTree.gempty in H. congruence.
  rewrite PTree.gsspec in H2. destruct (peq pc k).
  inv H2. unfold F. apply add_edges_instr_correct.
  apply correct_interf_instr_incl with a.
  unfold F; apply add_edges_instr_incl.
  apply H1; auto.
Qed.

(** Here are the three correctness properties of the generated
  inference graph.  First, it contains the conflict edges
  needed by every instruction of the function. *)

Lemma interf_graph_correct_1:
  forall f live live0 pc i,
  f.(fn_code)!pc = Some i ->
  correct_interf_instr live!!pc i (interf_graph f live live0).
Proof.
  intros. unfold interf_graph.
  apply correct_interf_instr_incl with (add_edges_instrs f live).
  eapply graph_incl_trans; [idtac|apply add_prefs_call_incl].
  eapply graph_incl_trans; [idtac|apply add_interf_params_incl].
  apply add_interf_entry_incl.
  apply add_edges_instrs_correct; auto.
Qed.

(** Second, function parameters conflict pairwise. *)

Lemma interf_graph_correct_2:
  forall f live live0 r1 r2,
  In r1 f.(fn_params) ->
  In r2 f.(fn_params) ->
  r1 <> r2 ->
  interfere r1 r2 (interf_graph f live live0).
Proof.
  intros. unfold interf_graph.
  eapply interfere_incl.
  apply add_prefs_call_incl.
  apply add_interf_params_correct; auto.
Qed.

(** Third, function parameters conflict pairwise with pseudo-registers
  live at function entry.  If the function never uses a pseudo-register
  before it is defined, pseudo-registers live at function entry
  are a subset of the function parameters and therefore this condition
  is implied by [interf_graph_correct_3].  However, we prefer not
  to make this assumption. *)

Lemma interf_graph_correct_3:
  forall f live live0 r1 r2,
  In r1 f.(fn_params) ->
  Regset.In r2 live0 ->
  r1 <> r2 ->
  interfere r1 r2 (interf_graph f live live0).
Proof.
  intros. unfold interf_graph.
  eapply interfere_incl.
  eapply graph_incl_trans; [idtac|apply add_prefs_call_incl].
  apply add_interf_params_incl.
  apply add_interf_entry_correct; auto.
Qed.

(** * Correctness of the a priori checks over the result of graph coloring *)

(** We now show that the checks performed over the candidate coloring
  returned by [graph_coloring] are correct: candidate colorings that
  pass these checks are indeed correct colorings. *)

Section CORRECT_COLORING.

Variable g: graph.
Variable env: regenv.
Variable allregs: Regset.t.
Variable coloring: reg -> loc.

Lemma check_coloring_1_correct:
  forall r1 r2,
  check_coloring_1 g coloring = true ->
  SetRegReg.In (r1, r2) g.(interf_reg_reg) ->
  coloring r1 <> coloring r2.
Proof.
  unfold check_coloring_1. intros.
  assert (compat_bool OrderedRegReg.eq
     (fun r1r2 => if Loc.eq (coloring (fst r1r2)) (coloring (snd r1r2))
                  then false else true)).
  red. unfold OrderedRegReg.eq. unfold OrderedReg.eq.
  intros x y [EQ1 EQ2]. rewrite EQ1; rewrite EQ2; auto.
  generalize (SetRegReg.for_all_2 H1 H H0).
  simpl. case (Loc.eq (coloring r1) (coloring r2)); intro.
  intro; discriminate. auto.
Qed.

Lemma check_coloring_2_correct:
  forall r1 mr2,
  check_coloring_2 g coloring = true ->
  SetRegMreg.In (r1, mr2) g.(interf_reg_mreg) ->
  coloring r1 <> R mr2.
Proof.
  unfold check_coloring_2. intros.
  assert (compat_bool OrderedRegMreg.eq
     (fun r1r2 => if Loc.eq (coloring (fst r1r2)) (R (snd r1r2))
                  then false else true)).
  red. unfold OrderedRegMreg.eq. unfold OrderedReg.eq.
  intros x y [EQ1 EQ2]. rewrite EQ1; rewrite EQ2; auto.
  generalize (SetRegMreg.for_all_2 H1 H H0).
  simpl. case (Loc.eq (coloring r1) (R mr2)); intro.
  intro; discriminate. auto.
Qed.

Lemma same_typ_correct:
  forall t1 t2, same_typ t1 t2 = true -> t1 = t2.
Proof.
  destruct t1; destruct t2; simpl; congruence.
Qed.

Lemma loc_is_acceptable_correct:
  forall l, loc_is_acceptable l = true -> loc_acceptable l.
Proof.
  destruct l; unfold loc_is_acceptable, loc_acceptable.
  case (In_dec Loc.eq (R m) temporaries); intro.
  intro; discriminate. auto.
  destruct s.
  case (zlt z 0); intro. intro; discriminate. auto.
  intro; discriminate.
  intro; discriminate.
Qed.

Lemma check_coloring_3_correct:
  forall r,
  check_coloring_3 allregs env coloring = true ->
  Regset.mem r allregs = true ->
  loc_acceptable (coloring r) /\ env r = Loc.type (coloring r).
Proof.
  unfold check_coloring_3; intros.
  exploit Regset.for_all_2; eauto.
  red; intros. congruence.
  apply Regset.mem_2. eauto.
  simpl. intro. elim (andb_prop _ _ H1); intros.
  split. apply loc_is_acceptable_correct; auto.
  apply same_typ_correct; auto.
Qed.

End CORRECT_COLORING.

(** * Correctness of clipping *)

(** We then show the correctness of the ``clipped'' coloring
  returned by [alloc_of_coloring] applied to a candidate coloring
  that passes the a posteriori checks. *)

Section ALLOC_OF_COLORING.

Variable g: graph.
Variable env: regenv.
Let allregs := all_interf_regs g.
Variable coloring: reg -> loc.
Let alloc := alloc_of_coloring coloring env allregs.

Lemma alloc_of_coloring_correct_1:
  forall r1 r2,
  check_coloring g env allregs coloring = true ->
  SetRegReg.In (r1, r2) g.(interf_reg_reg) ->
  alloc r1 <> alloc r2.
Proof.
  unfold check_coloring, alloc, alloc_of_coloring; intros.
  elim (andb_prop _ _ H); intros.
  generalize (all_interf_regs_correct_1 _ _ _ H0).
  intros [A B].
  unfold allregs. rewrite Regset.mem_1; auto. rewrite Regset.mem_1; auto.
  eapply check_coloring_1_correct; eauto.
Qed.

Lemma alloc_of_coloring_correct_2:
  forall r1 mr2,
  check_coloring g env allregs coloring = true ->
  SetRegMreg.In (r1, mr2) g.(interf_reg_mreg) ->
  alloc r1 <> R mr2.
Proof.
  unfold check_coloring, alloc, alloc_of_coloring; intros.
  elim (andb_prop _ _ H); intros.
  elim (andb_prop _ _ H2); intros.
  generalize (all_interf_regs_correct_2 _ _ _ H0). intros.
  unfold allregs. rewrite Regset.mem_1; auto.
  eapply check_coloring_2_correct; eauto.
Qed.

Lemma alloc_of_coloring_correct_3:
  forall r,
  check_coloring g env allregs coloring = true ->
  loc_acceptable (alloc r).
Proof.
  unfold check_coloring, alloc, alloc_of_coloring; intros.
  elim (andb_prop _ _ H); intros.
  elim (andb_prop _ _ H1); intros.
  caseEq (Regset.mem r allregs); intro.
  generalize (check_coloring_3_correct _ _ _ r H3 H4). tauto.
  case (env r); simpl.
  unfold dummy_int_reg. intuition congruence.
  unfold dummy_float_reg. intuition congruence.
Qed.

Lemma alloc_of_coloring_correct_4:
  forall r,
  check_coloring g env allregs coloring = true ->
  env r = Loc.type (alloc r).
Proof.
  unfold check_coloring, alloc, alloc_of_coloring; intros.
  elim (andb_prop _ _ H); intros.
  elim (andb_prop _ _ H1); intros.
  caseEq (Regset.mem r allregs); intro.
  generalize (check_coloring_3_correct _ _ _ r H3 H4). tauto.
  case (env r); reflexivity.
Qed.

End ALLOC_OF_COLORING.

(** * Correctness of the whole graph coloring algorithm *)

(** Combining results from the previous sections, we now summarize
  the correctness properties of the assignment (of locations to
  registers) returned by [regalloc]. *)

Definition correct_alloc_instr
    (live: PMap.t Regset.t) (alloc: reg -> loc)
    (pc: node) (instr: instruction) : Prop :=
  match instr with
  | Iop op args res s =>
      match is_move_operation op args with
      | Some arg =>
          forall r,
          Regset.In res live!!pc ->
          Regset.In r live!!pc ->
          r <> res -> r <> arg -> alloc r <> alloc res
      | None =>
          forall r,
          Regset.In res live!!pc ->
          Regset.In r live!!pc ->
          r <> res -> alloc r <> alloc res
      end
  | Iload chunk addr args res s =>
      forall r,
      Regset.In res live!!pc ->
      Regset.In r live!!pc ->
      r <> res -> alloc r <> alloc res
  | Icall sig ros args res s =>
      (forall r,
        Regset.In r live!!pc ->
        r <> res ->
        ~(In (alloc r) destroyed_at_call))
   /\ (forall r,
        Regset.In r live!!pc ->
        r <> res -> alloc r <> alloc res)
   /\ (match ros with
        | inl rfun => ~(In (alloc rfun) (loc_arguments sig))
        | inr idfun => True
        end)
  | Itailcall sig ros args =>
      (match ros with
        | inl rfun => ~(In (alloc rfun) (loc_arguments sig))
        | inr idfun => True
        end)
  | Ibuiltin ef args res s =>
      forall r,
      Regset.In r live!!pc ->
      r <> res -> alloc r <> alloc res
  | _ =>
      True
  end.

Section REGALLOC_PROPERTIES.

Variable f: function.
Variable env: regenv.
Variable live: PMap.t Regset.t.
Variable live0: Regset.t.
Variable alloc: reg -> loc.

Let g := interf_graph f live live0.
Let allregs := all_interf_regs g.
Let coloring := graph_coloring f g env allregs.

Lemma regalloc_ok:
  regalloc f live live0 env = Some alloc ->
  check_coloring g env allregs coloring = true /\
  alloc = alloc_of_coloring coloring env allregs.
Proof.
  unfold regalloc, coloring, allregs, g.
  case (check_coloring (interf_graph f live live0) env).
  intro EQ; injection EQ; intro; clear EQ.
  split. auto. auto.
  intro; discriminate.
Qed.

Lemma regalloc_acceptable:
  forall r,
  regalloc f live live0 env = Some alloc ->
  loc_acceptable (alloc r).
Proof.
  intros. elim (regalloc_ok H); intros.
  rewrite H1. unfold allregs. apply alloc_of_coloring_correct_3.
  exact H0.
Qed.

Lemma regsalloc_acceptable:
  forall rl,
  regalloc f live live0 env = Some alloc ->
  locs_acceptable (List.map alloc rl).
Proof.
  intros; red; intros.
  elim (list_in_map_inv _ _ _ H0). intros r [EQ IN].
  subst l. apply regalloc_acceptable. auto.
Qed.

Lemma regalloc_preserves_types:
  forall r,
  regalloc f live live0 env = Some alloc ->
  Loc.type (alloc r) = env r.
Proof.
  intros. elim (regalloc_ok H); intros.
  rewrite H1. unfold allregs. symmetry.
  apply alloc_of_coloring_correct_4.
  exact H0.
Qed.

Lemma correct_interf_alloc_instr:
  forall pc instr,
  (forall r1 r2, interfere r1 r2 g -> alloc r1 <> alloc r2) ->
  (forall r1 mr2, interfere_mreg r1 mr2 g -> alloc r1 <> R mr2) ->
  (forall r, loc_acceptable (alloc r)) ->
  correct_interf_instr live!!pc instr g ->
  correct_alloc_instr live alloc pc instr.
Proof.
  intros pc instr ALL1 ALL2 ALL3.
  unfold correct_interf_instr, correct_alloc_instr;
  destruct instr; auto.
  destruct (is_move_operation o l); auto.
  (* Icall *)
  intros [A [B C]].
  split. intros; red; intros.
  unfold destroyed_at_call in H1.
  generalize (list_in_map_inv R _ _ H1).
  intros [mr [EQ IN]].
  generalize (A r0 mr H IN H0). intro.
  generalize (ALL2 _ _ H2). contradiction.
  split. auto.
  destruct s0; auto. red; intros.
  generalize (ALL3 r0). generalize (loc_arguments_acceptable _ _ H).
  unfold loc_argument_acceptable, loc_acceptable.
  caseEq (alloc r0). intros.
  elim (ALL2 r0 m). apply C; auto. congruence. auto.
  destruct s0; auto.
  (* Itailcall *)
  destruct s0; auto. red; intros.
  generalize (ALL3 r). generalize (loc_arguments_acceptable _ _ H0).
  unfold loc_argument_acceptable, loc_acceptable.
  caseEq (alloc r). intros.
  elim (ALL2 r m). apply H; auto. congruence. auto.
  destruct s0; auto.
Qed.

Lemma regalloc_correct_1:
  forall pc instr,
  regalloc f live live0 env = Some alloc ->
  f.(fn_code)!pc = Some instr ->
  correct_alloc_instr live alloc pc instr.
Proof.
  intros. elim (regalloc_ok H); intros.
  apply correct_interf_alloc_instr.
  intros. rewrite H2. unfold allregs. red in H3.
  elim (ordered_pair_charact r1 r2); intro.
  apply alloc_of_coloring_correct_1. auto. rewrite H4 in H3; auto.
  apply sym_not_equal.
  apply alloc_of_coloring_correct_1. auto. rewrite H4 in H3; auto.
  intros. rewrite H2. unfold allregs.
  apply alloc_of_coloring_correct_2. auto. exact H3.
  intros. eapply regalloc_acceptable; eauto.
  unfold g. apply interf_graph_correct_1. auto.
Qed.

Lemma regalloc_correct_2:
  regalloc f live live0 env = Some alloc ->
  list_norepet f.(fn_params) ->
  list_norepet (List.map alloc f.(fn_params)).
Proof.
  intros. elim (regalloc_ok H); intros.
  apply list_map_norepet; auto.
  intros. rewrite H2. unfold allregs.
  elim (ordered_pair_charact x y); intro.
  apply alloc_of_coloring_correct_1. auto.
  change positive with reg. rewrite <- H6.
  change (interfere x y g). unfold g.
  apply interf_graph_correct_2; auto.
  apply sym_not_equal.
  apply alloc_of_coloring_correct_1. auto.
  change positive with reg. rewrite <- H6.
  change (interfere x y g). unfold g.
  apply interf_graph_correct_2; auto.
Qed.

Lemma regalloc_correct_3:
  forall r1 r2,
  regalloc f live live0 env = Some alloc ->
  In r1 f.(fn_params) ->
  Regset.In r2 live0 ->
  r1 <> r2 ->
  alloc r1 <> alloc r2.
Proof.
  intros. elim (regalloc_ok H); intros.
  rewrite H4; unfold allregs.
  elim (ordered_pair_charact r1 r2); intro.
  apply alloc_of_coloring_correct_1. auto.
  change positive with reg. rewrite <- H5.
  change (interfere r1 r2 g). unfold g.
  apply interf_graph_correct_3; auto.
  apply sym_not_equal.
  apply alloc_of_coloring_correct_1. auto.
  change positive with reg. rewrite <- H5.
  change (interfere r1 r2 g). unfold g.
  apply interf_graph_correct_3; auto.
Qed.

End REGALLOC_PROPERTIES.


Require Import BasicMachineTypes.
Require Import ClassDatatypesIface.
Require Import Peano_dec.
Require Import StoreIface.
Require Import OptionExt.
Require Import List.
Require Import ListExt.
Require Import Compare_dec.
Require Import Arith.
Require Import Certificates.
Require Import VerifierAnnotationsIface.
Require Import AbstractLogic.
Require Import VCs.
Require Import ErrorMonad.
Require Import ErrorMessages.
Require Import MLStrings.
Require Import NativeMethodSpec.
Require Import Setoid.
Require Import Omega.

Module Type CODE_VERIFIER_BASE
  (B : BASICS)
  (AL : ABSTRACT_LOGIC B)
  (CERT : CERTIFICATE with Definition asn := AL.formula)
  (ANN : VERIFIER_ANNOTATIONS B AL CERT)
  (C : CLASSDATATYPES B ANN.GA.A).

Parameter instruction_precondition :
  CERT.Cert.t ->
  C.ConstantPool.t ->
  AL.formula ->
  AL.formula ->
  ANN.ConstantPoolAdditional.t ->
  list C.exception_handler ->
  C.opcode ->
  nat ->
  AL.formula ->
  Prop.

Parameter get_instruction_precondition :
  CERT.Cert.t ->
  C.ConstantPool.t ->
  AL.formula ->
  AL.formula ->
  ANN.ConstantPoolAdditional.t ->
  list C.exception_handler ->
  C.opcode ->
  nat ->
  error_monad AL.formula.

Hypothesis get_instruction_precondition_sound : forall cert cp ensures ex_ensures cpa handlers op pc a,
  get_instruction_precondition cert cp ensures ex_ensures cpa handlers op pc = Val a ->
  instruction_precondition cert cp ensures ex_ensures cpa handlers op pc a.

Hypothesis cert_incl_instruction_precondition : forall cert cert' cp ensures ex_ensures cpa handlers op pc a,
  CERT.cert_incl cert cert' ->
  instruction_precondition cert cp ensures ex_ensures cpa handlers op pc a ->
  instruction_precondition cert' cp ensures ex_ensures cpa handlers op pc a.

End CODE_VERIFIER_BASE.

Module MkCodeVerifier (B     : BASICS)
                      (AL    : ABSTRACT_LOGIC B)
                      (CERT  : CERTIFICATE with Definition asn := AL.formula)
                      (ANN   : VERIFIER_ANNOTATIONS B AL CERT)
                      (C     : CLASSDATATYPES B ANN.GA.A)
                      (Base  : CODE_VERIFIER_BASE B AL CERT ANN C)
                      (NTSPC : NATIVE_METHOD_SPEC B ANN.GA.A)
                      (VCs   : VERIFICATION_CONDITIONS B AL).

Import CERT.

Section ErrorHandling.

Definition getproof (prooftable : ANN.ProofTable.t) (hyp res : AL.formula) :=
  tagoptfail (err_noproof mlapp (AL.string_of_formula hyp) mlapp
              err_entails mlapp (AL.string_of_formula res))
  (ANN.ProofTable.lookup prooftable (hyp, res)).

End ErrorHandling.

Section CodeVerification.

Hypothesis cp : C.ConstantPool.t.
Hypothesis cpa : ANN.ConstantPoolAdditional.t.
Hypothesis ensures ex_ensures : AL.formula.

Inductive verified_instruction (cert:Cert.t)
                               (handlers : list C.exception_handler)
                               (op : C.opcode)
                               (pc : nat) : Prop :=
| mk_verified_instruction : forall a1 a2,
    CERT.Cert.lookup cert pc = Some a1 ->
    Base.instruction_precondition cert cp ensures ex_ensures cpa handlers op pc a2 ->
    AL.implies a1 a2 ->
    verified_instruction cert handlers op pc.

Hypothesis code : C.precode.

Inductive verified_precode (cert:Cert.t) : Prop :=
| mk_verified_code :
    (* the certificate only covers the actual code *)
    (forall n a, CERT.Cert.lookup cert n = Some a -> n < length (C.precode_code code)) ->
    (* all the actual instructions are safe *)
    (forall n op, nth_error (C.precode_code code) n = Some op ->
      verified_instruction cert (C.precode_exception_table code) op n) ->
    verified_precode cert.

(* now we try to complete certificates *)

Hypothesis prooftable : ANN.ProofTable.t.

Definition method_vc := (VCs.VerificationConditions.key * nat)%type.

Definition completion_step : Cert.t -> nat -> C.opcode -> error_monad (Cert.t * list method_vc) :=
  fun cert pc op =>
  a <- Base.get_instruction_precondition cert cp ensures ex_ensures cpa (C.precode_exception_table code) op pc;:
  match Cert.lookup cert pc with
  | None => ret (Cert.update cert pc a, nil)
  | Some a' =>
     ret (cert, ((a',a),pc)::nil)
  end.

Fixpoint complete_cert_aux (ops:list C.opcode) (cert:Cert.t) (pc:nat) {struct ops} : error_monad (Cert.t * list method_vc) :=
  match ops with
  | nil     => fail err_emptycode
  | op::nil => completion_step cert pc op
  | op::ops => p1 <- complete_cert_aux ops cert (S pc);:
               match p1 with (cert',vcs) =>
                 p2 <- completion_step cert' pc op;:
                 match p2 with (cert'',vcs') =>
                   ret (cert'',vcs' ++ vcs)
                 end
               end
  end.

Definition complete_cert : error_monad (Cert.t * list method_vc) :=
  complete_cert_aux (C.precode_code code) (clean_cert (C.precode_annot code) (length (C.precode_code code))) 0.

Lemma step_incl : forall c c' vc n op, completion_step c n op = Val (c',vc) -> cert_incl c c'.
intros. unfold completion_step in H.
destruct (Base.get_instruction_precondition c cp ensures ex_ensures cpa (C.precode_exception_table code) op n) as [l|]; [|discriminate].
destruct (option_dec (Cert.lookup c n)) as [[a cert_lookup_result] | cert_lookup_result];
 rewrite cert_lookup_result in H.
 simpl in H. inversion H. apply cert_incl_refl.
 inversion H. apply cert_incl_update. apply cert_lookup_result.
Save.

Lemma complete_cert_incl : forall c c' vcs n ops,
  complete_cert_aux ops c n = Val (c',vcs) -> cert_incl c c'.
intros. generalize n c' vcs H. clear n c' vcs H.
induction ops; intros.
 discriminate.
 simpl in H. destruct ops.
  eapply step_incl. apply H.
  destruct_err (complete_cert_aux (o::ops) c (S n)) H cert'vcs' complete_cert_aux_result.
  destruct cert'vcs' as [cert' vcs'].
   eapply cert_incl_trans.
    eapply IHops. apply complete_cert_aux_result.
    destruct_err (completion_step cert' n a) H cert''vcs'' result.
    destruct cert''vcs'' as [cert'' vcs''].
    inversion H. subst.
    eapply step_incl.
    apply result.
Save.

Lemma complete_cert_aux_prop : forall n ops c c' vcs, n < length ops ->
  complete_cert_aux ops c 0 = Val (c',vcs) ->
  (exists c'', exists vcs'', complete_cert_aux (tail n ops) c n = Val (c'',vcs'')
               /\ cert_incl c c''
               /\ cert_incl c'' c'
               /\ forall vc, In vc vcs'' -> In vc vcs).
intros n ops c c' vcs n_lt_len_ops complete_cert_aux_result.
rewrite <- (tail_0 ops) in complete_cert_aux_result.
pose (n':=n). assert (n_lt_n':n'<=n) by (auto with arith). replace 0 with (n-n') in complete_cert_aux_result by auto with arith.
pose (c3:=c'). assert (c3_incl_c':cert_incl c3 c') by (apply cert_incl_refl). replace c' with c3 in complete_cert_aux_result by reflexivity.
generalize c vcs c3 c3_incl_c' complete_cert_aux_result n_lt_n'. clear c vcs c3 c3_incl_c' complete_cert_aux_result n_lt_n'.
induction n'; intros.
 (* base case *)
 rewrite <- minus_n_O in complete_cert_aux_result. exists c3. exists vcs. intuition.
 eapply complete_cert_incl. apply complete_cert_aux_result.
 (* step case *)
 destruct (tail_minus ops n' n) as [op tail_eq]. omega. assumption.
 rewrite tail_eq in complete_cert_aux_result.
 simpl in complete_cert_aux_result.
 destruct (tail_S (n-n') ops) as [op' tail_eq']. omega.
 rewrite tail_eq' in complete_cert_aux_result.
 destruct_err (complete_cert_aux (op' :: tail (S (n - n')) ops) c (S (n - S n'))) complete_cert_aux_result cert'vcs' complete_cert_aux_result'.
 destruct cert'vcs' as [cert' vcs'].
  rewrite <- tail_eq' in complete_cert_aux_result'.
  replace (S (n - S n')) with (n-n') in complete_cert_aux_result'.
  destruct_err (completion_step cert' (n - S n') op) complete_cert_aux_result c3vcs result.
  destruct c3vcs. inversion complete_cert_aux_result.  subst.
  assert (cert'_c3 : cert_incl cert' c3).
   eapply step_incl.
   eassumption.
  assert (cert'_c' : cert_incl cert' c').
   eapply cert_incl_trans;eauto.
  destruct (IHn' _ _ _ cert'_c' complete_cert_aux_result') as [c'' [vcs'' [cca [incl1 [incl2 vc_in]]]]].
   omega.
   exists c''. exists vcs''. intuition.
   omega.
Save.

Lemma completion_step_clean : forall c c' vcs pc op limit,
  pc < limit ->
  completion_step c pc op = Val (c',vcs) ->
  (forall n, n >= limit -> Cert.lookup c n = None) ->
  (forall n, n >= limit -> Cert.lookup c' n = None).
intros.
unfold completion_step in H0.
destruct (Base.get_instruction_precondition c cp ensures ex_ensures cpa (C.precode_exception_table code) op pc) as [l|]; [|discriminate].
destruct (Cert.lookup c pc) as [a|].
 inversion H0. subst c'. eauto.
 inversion H0. subst c'. rewrite (Cert.indep_lookup c pc n); [auto|unfold Cert.Key.eq; omega].
Save.

Lemma complete_cert_aux_clean : forall c c' vcs n ops,
  (forall m, m >= n+length ops -> Cert.lookup c m = None) ->
  complete_cert_aux ops c n = Val (c',vcs) ->
  (forall m, m >= n+length ops -> Cert.lookup c' m = None).
intros. generalize n c' vcs H H0 m H1. clear n c' vcs H H0 m H1.
induction ops; intros.
 (* base case *)
 discriminate.
 (* step case *)
 simpl in H0.
 destruct ops.
  apply (completion_step_clean c c' vcs n a (n+length (a::nil))).
   simpl. omega.
   apply H0.
   apply H.
   apply H1.
  destruct_err (complete_cert_aux (o::ops) c (S n)) H0 cert'vcs complete_cert_aux_result.
  destruct cert'vcs as [cert' vcs'].
  destruct_err (completion_step cert' n a) H0 cert''vcs'' completion_step_result.
  destruct cert''vcs'' as [cert'' vcs''].
  inversion H0. subst c'.
   apply (completion_step_clean cert' cert'' vcs'' n a (n+length (a::o::ops))); auto.
    simpl. omega.
    intros. eapply (IHops (S n)); eauto.
     intros. apply H. simpl. simpl in H3. omega.
     simpl. simpl in H2. omega.
Save.

Lemma step_ok : forall c c' vcs op pc,
  completion_step c pc op = Val (c',vcs) ->
  (forall f f' s, In ((f,f'),s) vcs -> AL.implies f f') ->
  verified_instruction c' (C.precode_exception_table code) op pc.
intros. unfold completion_step in H.
destruct_err (Base.get_instruction_precondition c cp ensures ex_ensures cpa (C.precode_exception_table code) op pc) H a vcgen_result.
 destruct (option_dec (Cert.lookup c pc)) as [[a' lookup_res]|lookup_res]; rewrite lookup_res in H.
  inversion H. subst. eapply mk_verified_instruction; eauto.
   apply Base.get_instruction_precondition_sound. eassumption.
   eapply H0. left. reflexivity.
  inversion H. eapply mk_verified_instruction.
   apply Cert.lookup_update.
   eapply Base.cert_incl_instruction_precondition.
    apply CERT.cert_incl_update. assumption.
    apply Base.get_instruction_precondition_sound. eassumption.
   apply AL.implies_refl.
Save.

Lemma cert_incl_safe : forall handlers c1 c2 pc op,
   verified_instruction c1 handlers op pc -> cert_incl c1 c2 -> verified_instruction c2 handlers op pc.
intros.
destruct H.
eapply mk_verified_instruction.
  eapply cert_incl_lookup. apply H. apply H0.
  eapply Base.cert_incl_instruction_precondition. apply H0. apply H1.
  assumption.
Save.

Lemma complete_cert_ok : forall cert' vcs,
  complete_cert = Val (cert',vcs) ->
  (forall f f' s, In ((f,f'),s) vcs -> AL.implies f f') ->
  verified_precode cert'.
intros. unfold complete_cert in H.
eapply mk_verified_code.
 (* Only the positions in the certificate are mentioned *)
 apply clean_contra. intros.
 apply (complete_cert_aux_clean (clean_cert (C.precode_annot code) (length (C.precode_code code))) cert' vcs 0 (C.precode_code code)).
  intros. apply clean_ok. assumption.
  apply H.
  simpl. assumption.
 (* all instructions are safe *)
 intros.
 destruct (complete_cert_aux_prop n (C.precode_code code) _ cert' _ (nth_error_length_2 _ _ _ _ H1) H)
  as [cert'' [vcs' [complete_cert_aux_result [cert_incl_1 [cert_incl_2 vcs_incl]]]]].
 destruct (tail_nth_error n (C.precode_code code) op H1) as [ops tail_eq].
 rewrite tail_eq in complete_cert_aux_result. simpl in complete_cert_aux_result.
 destruct ops.
  eapply cert_incl_safe. eapply step_ok. apply complete_cert_aux_result.
   intros. eapply H0. apply vcs_incl. apply H2.
   apply cert_incl_2.
  destruct_err (complete_cert_aux (o::ops) (clean_cert (C.precode_annot code) (length (C.precode_code code))) (S n))
   complete_cert_aux_result cert''' complete_cert_aux_result'.
  destruct cert''' as [cert''' vcs'''].
  destruct_err (completion_step cert''' n op) complete_cert_aux_result cert'4 complete_cert_aux_result''.
  destruct cert'4 as [cert'4 vcs'4].
  inversion complete_cert_aux_result. subst cert'4 vcs'.
  eapply cert_incl_safe.
   eapply step_ok. apply complete_cert_aux_result''. intros. eapply H0. apply vcs_incl. apply List.in_or_app. left. apply H2.
   apply cert_incl_2.
Save.

End CodeVerification.

Module VCFacts := OrderedType.OrderedTypeFacts VCs.VerificationConditions.E.

Section PreclassVerification.

Hypothesis pcl : C.preclass.
Hypothesis ispriv : bool.
Definition prooftable : ANN.ProofTable.t := fst (C.preclass_annotation pcl).

(* Adapted from the full record definition in ResourceSafety. *)
Definition
preclass_verified_methods : Prop :=
(forall md pm,
  C.has_premethod (C.preclass_methods pcl) md pm ->
  (exists code, forall P Q X,
    ANN.method_spec (C.premethod_annot pm) = (P, Q, X) ->
    exists cert, exists P', exists Q',
      C.premethod_code pm = Some code
      /\ ((exists g, ANN.grants (C.premethod_annot pm) = Some g /\ ispriv = true /\ Q' = AL.given_resexpr_have g Q)
        \/ (ANN.grants (C.premethod_annot pm) = None /\ Q' = Q))
      /\ verified_precode (C.preclass_constantpool pcl) (snd (C.preclass_annotation pcl)) Q' X code cert
      /\ AL.implies P P'
      /\ Cert.lookup cert 0 = Some P')
  \/
(* TO DO: should we check that the method is declared native rather than abstract? *)
  (C.premethod_code pm = None /\
    (C.premethod_abstract pm = true \/
      (NTSPC.SpecTable.MapsTo (C.preclass_name pcl, (C.premethod_name pm)) (C.premethod_annot pm) NTSPC.table /\
        (ispriv = true \/ ANN.grants (C.premethod_annot pm) = None)))))
.

Definition check_method (pm : C.premethod) : error_monad (Cert.t * list method_vc) :=
  tagfailure (err_checkmethod mlapp (B.Methodname.to_string (C.premethod_name pm)) mlapp err_sep)
  match C.premethod_code pm with
    | None => if C.premethod_abstract pm then ret (Cert.empty, nil) else
      match NTSPC.SpecTable.find (C.preclass_name pcl, C.premethod_name pm) NTSPC.table with
        | None => fail err_native_missing
        | Some annotation =>
          if ANN.method_annotation_eqdec annotation (C.premethod_annot pm)
            then
              match ANN.grants (C.premethod_annot pm) with
                | None => ret (Cert.empty, nil)
                | Some _ =>
                  if ispriv then ret (Cert.empty, nil)
                    else fail err_grants_no_privilege
              end
            else fail err_native_bad_spec
      end
    | Some code =>
      match ANN.method_spec (C.premethod_annot pm) with (P, Q, X) =>
        Q' <- match ANN.grants (C.premethod_annot pm) with
                | None => ret Q
                | Some g =>
                  if ispriv then ret (AL.given_resexpr_have g Q)
                    else fail err_grants_no_privilege
              end;:
        r <- complete_cert (C.preclass_constantpool pcl) (snd (C.preclass_annotation pcl)) Q' X code;:
        match r with (cert,vcs) =>
          (* Perhaps we can establish that this will never fail? *)
          P' <- tagoptfail err_incomplete (Cert.lookup cert O);:
          ret (cert, ((P,P'),0)::vcs)
        end
      end
  end.

Lemma check_method_ok : forall P Q X pm cert code vcs,
  C.premethod_code pm = Some code ->
  ANN.method_spec (C.premethod_annot pm) = (P, Q, X) ->
  check_method pm = Val (cert, vcs) ->
  (forall f f' s, In ((f,f'),s) vcs -> AL.implies f f') ->
  exists P', exists Q', C.premethod_code pm = Some code /\
  ((exists g, ANN.grants (C.premethod_annot pm) = Some g /\ ispriv = true /\ Q' = AL.given_resexpr_have g Q) \/
  (ANN.grants (C.premethod_annot pm) = None /\ Q' = Q)) /\
  verified_precode
  (C.preclass_constantpool pcl)
  (snd (C.preclass_annotation pcl))
  Q'
  X
  code
  cert
  /\ AL.implies P P'
  /\ Cert.lookup cert O = Some P'.
Proof.
intros until vcs.
intros method_code annot check vcs_ok.
unfold check_method in check.
unfold tagfailure in check.
(* We get the same code as before. *)
destruct (C.premethod_code pm).
injection method_code as codeeq'.
rewrite codeeq' in * |- *.
clear codeeq'.

rewrite annot in * |- *.

destruct_err (match ANN.grants (C.premethod_annot pm) return error_monad AL.formula with
                | Some g =>
                  if ispriv
                    then ret (T:=AL.formula) (AL.given_resexpr_have g Q)
                    else fail (T:=AL.formula) err_grants_no_privilege
                | None => ret (T:=AL.formula) Q
              end) check Q' Q'eq.
destruct_err (complete_cert (C.preclass_constantpool pcl) (snd (C.preclass_annotation pcl)) Q' X code) check cert' certeq.
destruct cert' as [cert' vcs'].
destruct_err (tagoptfail err_incomplete (Cert.lookup cert' O)) check P' P'eq.
inject_opttag P'eq.
injection check. intros vc_eq cert_eq. subst cert' vcs.

exists P'. exists Q'.
split; auto.
split; auto.
 destruct (ANN.grants (C.premethod_annot pm)) as [g|].
  left; exists g; intuition; destruct ispriv; [reflexivity|discriminate|injection Q'eq as Qeq; auto|discriminate].
  injection Q'eq as Qeq; right; intuition.
split. eapply complete_cert_ok; eauto.
intros. eapply vcs_ok. right. apply H.
split. eapply vcs_ok.  left. reflexivity.
assumption.

discriminate.

Save.

Fixpoint testall (T:Set) (f:T -> option error) (l:list T) :=
  match l with
    | nil => None
    | h::t => match f h with
                | None => testall T f t
                | Some e => Some e
              end
  end.

Implicit Arguments testall [T].

Lemma testall_ok: forall T f l, testall (T:=T) f l = None ->
                  forall i, In (A:=T) i l -> f i = None.
Proof.
induction l.
contradiction.
intros code i iinl.
simpl in code.
destruct (in_inv iinl).
rewrite H in * |- *.
destruct (f i).
discriminate.
reflexivity.

destruct (f a).
discriminate.
apply IHl; assumption.
Save.

Definition add_vcs (t:VCs.vcset) (vcs:list method_vc) (c:B.Classname.t) (m:B.Methodname.t):=
  List.fold_left (fun vcs vc => match vc with (vc',s) => VCs.add_vc vcs vc' (VCs.vc_spec c m s) end) vcs t.

Lemma add_vcs_mono : forall l t t' c m vc,
  add_vcs t l c m = t' ->
  VCs.VerificationConditions.In vc t ->
  VCs.VerificationConditions.In vc t'.
Proof.
  induction l; intros.
    simpl in H.
    subst. assumption.

    destruct a as [vc' src].
    simpl in H.
    unfold VCs.add_vc in H.
    destruct H0 as [s0 lookup].
    set (vc'' := VCs.simplify_vc vc') in *.
    destruct (VCFacts.eq_dec vc vc'') as [vc_eq|vc_neq].
      apply (VCs.VerificationConditions.MapsTo_1 (elt:=VCs.vc_sources) (m:=t) (e:=s0) vc_eq) in lookup.
      rewrite (VCs.VerificationConditions.find_1 lookup) in H.
      eapply IHl; eauto.
      exists ((VCs.vc_spec c m src)::s0).
      apply VCs.VerificationConditions.add_1.
      apply VCs.VerificationConditions.E.eq_sym.
      assumption.

      eapply IHl; eauto.
      unfold VCs.VerificationConditions.In.
      eapply ex_intro.
      apply VCs.VerificationConditions.add_2; eauto.
Qed.

Lemma add_vcs_ok : forall vcs t t' c m f f' src,
  add_vcs t vcs c m = t' -> In ((f,f'),src) vcs ->
  VCs.VerificationConditions.In (VCs.simplify_vc (f,f')) t'.
Proof.
  induction vcs; intros.
    destruct H0.

    inversion H0.
      subst a.
      simpl in H.
      eapply add_vcs_mono; eauto.
      unfold VCs.add_vc.
      destruct (VCs.VerificationConditions.find (VCs.simplify_vc (f, f')) t).
        exists ((VCs.vc_spec c m src) :: v).
        apply VCs.VerificationConditions.add_1.
        apply VCs.VerificationConditions.E.eq_refl.

        exists ((VCs.vc_spec c m src) :: nil).
        apply VCs.VerificationConditions.add_1.
        apply VCs.VerificationConditions.E.eq_refl.

      eapply IHvcs; eauto.
      simpl in H.
      apply H.
Qed.

Definition check_preclass_methods : error_monad VCs.vcset :=
  List.fold_left (fun vcs_e m =>
    vcs <- vcs_e;:
    r <- check_method m;:
    match r with (cert, m_vcs) =>
      ret (add_vcs vcs m_vcs (C.preclass_name pcl) (C.premethod_name m))
    end) (C.preclass_methods pcl) (ret (VCs.VerificationConditions.empty VCs.vc_sources)).

Lemma check_preclass_methods_ok : forall vcs,
  check_preclass_methods = Val vcs ->
  (forall p p', VCs.VerificationConditions.In (p,p') vcs -> AL.implies p p') ->
  preclass_verified_methods.
Proof.
  intros vcs exec vcs_ok.
  unfold check_preclass_methods in exec.
  unfold preclass_verified_methods.
  intros.
  set (init_vcs := VCs.VerificationConditions.empty VCs.vc_sources) in *.
  clearbody init_vcs.
  revert init_vcs exec.
  induction (C.preclass_methods pcl); intros.
    inversion H.

    inversion H.
      (* This is the right method. *)
      rewrite H3 in *.
      subst a md.
      simpl in exec.
      case_eq (check_method pm).
        intros [m_cert m_vcs] check.
        destruct code as [code'|] _eqn: code_eq.
          left.
          exists code'.
          exists m_cert.
          eapply check_method_ok; auto. subst pm; reflexivity. eassumption.
          intros.
          assert (vcs_incl : VCs.VerificationConditions.In (VCs.simplify_vc (f,f')) vcs).
            subst meths.
            clear IHl.
            rewrite check in exec.
            simpl in exec.
            set (suff_vcs := add_vcs init_vcs m_vcs (C.preclass_name pcl) (C.premethod_name pm)) in exec.
            (* Establish that adding to the vcs now will ensure that the vc is in
               the final result. *)
            assert (have_vc : VCs.VerificationConditions.In (VCs.simplify_vc (f,f')) suff_vcs) by apply (add_vcs_ok _ _ _ _ _ _ _ _ (refl_equal suff_vcs) H1).
            clearbody suff_vcs.
            revert suff_vcs have_vc exec.
            induction l; intros.
              simpl in exec.
              inject_err exec.
              subst vcs.
              assumption.

              simpl in exec.
              destruct (check_method a) as [[a_cert a_vcs]|].
                simpl in exec.
                set (new_vcs := add_vcs suff_vcs a_vcs (C.preclass_name pcl) (C.premethod_name a)) in *.
                assert (new_vcs_is : (add_vcs suff_vcs a_vcs (C.preclass_name pcl) (C.premethod_name a) = new_vcs)) by reflexivity.
                eapply IHl.
                  rewrite <- H3.
                  apply C.has_premethod_cons_1.

                  eapply add_vcs_mono. apply new_vcs_is.
                  apply have_vc.

                  apply exec.

                (* We have to show that failures are propogated to the end. *)
                elimtype False.
                clear - exec.
                induction l.
                  discriminate.

                  apply IHl.
                    assumption.

          unfold VCs.simplify_vc in vcs_incl.
          eapply AL.implies_trans.
            apply (proj1 (AL.simplify_ok f)).
            eapply AL.implies_trans.
              eapply vcs_ok. apply vcs_incl.
              apply (proj2 (AL.simplify_ok f')).

        right. subst pm. split.
          reflexivity.
          unfold check_method in check. simpl in check.
          destruct abstract; auto.
          right.
          simpl in *. destruct (NTSPC.SpecTable.find (C.preclass_name pcl, nm) NTSPC.table) as [spec|] _eqn:finds; try discriminate.
          destruct (ANN.method_annotation_eqdec spec annot); try discriminate;
          destruct (ANN.grants annot); destruct ispriv; try discriminate;
          (split;
            [apply NTSPC.SpecTable.find_2; rewrite finds;
              simpl in check; inversion check; subst spec; reflexivity| tauto]).

      (* Again, propogate failures. *)
      intros.
      rewrite H0 in *.
      elimtype False.
      clear - exec.
      induction l.
        discriminate.

        auto.

    (* This is some other method *)
    subst meths md m.
    simpl in exec.
    destruct (check_method a) as [[a_cert a_vcs]|].
      simpl in exec.
      eapply IHl; auto.
        apply exec.

      (* Again, propogate failures. *)
      elimtype False.
      clear - exec.
      induction l; [discriminate|auto].
Qed.

End PreclassVerification.

End MkCodeVerifier.

(*
   Local Variables:
   coq-prog-args: ("-emacs-U" "-I" ".." "-R" "../ill" "ILL" "-R" "." "Verifier")
   End:
   *)


(** * Definition of minimal parse trees *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Setoids.Setoid.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.

Local Coercion is_true : bool >-> Sortclass.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {G : grammar Char}.
  Context {predata : @parser_computational_predataT Char}
          {rdata' : @parser_removal_dataT' _ G predata}.

  (** The [nonterminals_listT] is the current list of valid nonterminals to compare
      against; the extra [String] argument to some of these is the
      [String] we're using to do well-founded recursion, which the
      current [String] must be no longer than. *)

  Inductive minimal_parse_of
  : forall (len0 : nat) (valid : nonterminals_listT)
           (str : String),
      productions Char -> Type :=
  | MinParseHead : forall len0 valid str pat pats,
                     @minimal_parse_of_production len0 valid str pat
                     -> @minimal_parse_of len0 valid str (pat::pats)
  | MinParseTail : forall len0 valid str pat pats,
                     @minimal_parse_of len0 valid str pats
                     -> @minimal_parse_of len0 valid str (pat::pats)
  with minimal_parse_of_production
  : forall (len0 : nat) (valid : nonterminals_listT)
           (str : String),
      production Char -> Type :=
  | MinParseProductionNil : forall len0 valid str,
                              length str = 0
                              -> @minimal_parse_of_production len0 valid str nil
  | MinParseProductionCons : forall len0 valid str n pat pats,
                               length str <= len0
                               -> @minimal_parse_of_item len0 valid (take n str) pat
                               -> @minimal_parse_of_production len0 valid (drop n str) pats
                               -> @minimal_parse_of_production len0 valid str (pat::pats)
  with minimal_parse_of_item
  : forall (len0 : nat) (valid : nonterminals_listT)
           (str : String),
      item Char -> Type :=
  | MinParseTerminal : forall len0 valid str ch P,
                         is_true (P ch)
                         -> str ~= [ ch ]
                         -> @minimal_parse_of_item len0 valid str (Terminal P)
  | MinParseNonTerminal
    : forall len0 valid str (nt : String.string),
        @minimal_parse_of_nonterminal len0 valid str nt
        -> @minimal_parse_of_item len0 valid str (NonTerminal nt)
  with minimal_parse_of_nonterminal
  : forall (len0 : nat) (valid : nonterminals_listT)
           (str : String),
      String.string -> Type :=
  | MinParseNonTerminalStrLt
    : forall len0 valid (nt : String.string) str,
        length str < len0
        -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt)
        -> @minimal_parse_of (length str) initial_nonterminals_data str (Lookup G nt)
        -> @minimal_parse_of_nonterminal len0 valid str nt
  | MinParseNonTerminalStrEq
    : forall len0 str valid nonterminal,
        length str = len0
        -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal)
        -> is_valid_nonterminal valid (of_nonterminal nonterminal)
        -> @minimal_parse_of len0 (remove_nonterminal valid (of_nonterminal nonterminal)) str (Lookup G nonterminal)
        -> @minimal_parse_of_nonterminal len0 valid str nonterminal.

End cfg.


From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
Require Import Eqdep_dec List.
From cap_machine Require Import rules.
From cap_machine Require Export addr_reg_sample region_macros contiguous stack_macros_helpers.
From cap_machine Require Export req.

Section stack_macros.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          `{MP: MachineParameters}.

  (* TODO: move this to the rules_Lea.v file. small issue with the spec of failure: it does not actually
     require/leave a trace on dst! It would be good if req_regs of a failing get does not include dst (if possible) *)
  Lemma wp_Lea_fail_U Ep pc_p pc_g pc_b pc_e pc_a w r1 rv p g b e a z a' :
    decodeInstrW w = Lea r1 (inr rv) →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (a + z)%a = Some a' ->
     (match p with
      | URW | URWL | URWX | URWLX => (a < a')%a
      | _ => False
      end) ->

     {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
           ∗ ▷ pc_a ↦ₐ w
           ∗ ▷ r1 ↦ᵣ inr ((p,g),b,e,a)
           ∗ ▷ rv ↦ᵣ inl z }}}
       Instr Executable @ Ep
     {{{ RET FailedV; True }}}.
  Proof.
    iIntros (Hdecode Hvpc Hz Hp φ) "(>HPC & >Hpc_a & >Hsrc & >Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hsrc Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_lea with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
      by rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)".
    iDestruct "Hspec" as %Hspec.
    destruct Hspec as [* Hsucc |].
    { (* Success (contradiction) *) simplify_map_eq. destruct p0; try done; revert Hp H5;clear;solve_addr. }
    { (* Failure, done *) by iApply "Hφ". }
  Qed.

  Definition prepstackU_instrs r (minsize paramsize: nat) :=
    reqperm_instrs r (encodePerm URWLX) ++
    reqsize_instrs r (minsize + paramsize) ++
    [getb r_t1 r;
    geta r_t2 r;
    sub_r_z r_t2 r_t2 paramsize;
    sub_r_r r_t1 r_t1 r_t2;
    lea_r r r_t1;
    move_z r_t1 0;
    move_z r_t2 0].

  Definition prepstackU r minsize paramsize a : iProp Σ :=
    ([∗ list] a_i;w_i ∈ a;(prepstackU_instrs r minsize paramsize), a_i ↦ₐ w_i)%I.

  Lemma prepstackU_spec r minsize paramsize a w pc_p pc_g pc_b pc_e a_first a_last φ :
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last ->
    contiguous_between a a_first a_last ->

      ▷ prepstackU r minsize paramsize a
    ∗ ▷ PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,a_first)
    ∗ ▷ r ↦ᵣ w
    ∗ ▷ (∃ w, r_t1 ↦ᵣ w)
    ∗ ▷ (∃ w, r_t2 ↦ᵣ w)
    ∗ ▷ (if isPermWord w URWLX then
           ∃ l b e a', ⌜w = inr (URWLX,l,b,e,a')⌝ ∧
           if (minsize + paramsize <? e - b)%Z then
             if ((b + paramsize) <=? a')%Z then
               ((∃ a_param, ⌜(b + paramsize)%a = Some a_param⌝ ∧
                   PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,a_last) ∗ prepstackU r minsize paramsize a ∗
                   r ↦ᵣ inr (URWLX,l,b,e,a_param) ∗ r_t1 ↦ᵣ inl 0%Z ∗ r_t2 ↦ᵣ inl 0%Z)
                   -∗ WP Seq (Instr Executable) {{ φ }})
             else φ FailedV
           else φ FailedV
         else φ FailedV)
    ⊢
      WP Seq (Instr Executable) {{ φ }}.
  Proof.
    iIntros (Hvpc Hcont) "(>Hprog & >HPC & >Hr & >Hr_t1 & >Hr_t2 & Hφ)".
    iDestruct (big_sepL2_length with "Hprog") as %Hlength. simpl in *.
    iAssert (⌜r ≠ PC⌝)%I as %Hne.
    { destruct (decide (r = PC)); auto; subst. iDestruct (regname_dupl_false with "HPC Hr") as %Hcontr. done. }
    (* reqperm *)
    iPrologue_multi "Hprog" Hcont Hvpc link.
    iApply (reqperm_spec with "[$HPC $Hcode $Hr $Hr_t1 $Hr_t2 Hφ Hprog]"); [apply Hvpc_code|apply Hcont_code|].
    iNext. destruct (isPermWord w URWLX); auto.
    iDestruct "Hφ" as (l b e a' Heq) "Hφ".
    subst. iExists l,b,e,a'. iSplit; auto.
    iIntros "(HPC & Hprog_done & Hr & Hr_t1 & Hr_t2)".
    (* reqsize *)
    iPrologue_multi "Hprog" Hcont Hvpc link0.
    iApply (reqsize_spec with "[- $HPC $Hcode $Hr $Hr_t1 $Hr_t2]");
      [apply Hvpc_code0|eauto|].
    iNext. destruct (minsize + paramsize <? e - b)%Z eqn:Hsize; auto.
    iIntros "H". iDestruct "H" as (w1 w2) "(Hreqsize & HPC & Hr & Hr_t1 & Hr_t2)".
    (* getb r_t1 r *)
    iDestruct (big_sepL2_length with "Hprog") as %Hlength'.
    prep_addr_list_full l_rest0 Hcont.
    iPrologue "Hprog".
    iApply (wp_Get_success with "[$HPC $Hi $Hr $Hr_t1]");
      [apply decode_encode_instrW_inv|auto|iCorrectPC link0 a_last|iContiguous_next Hcont 0|auto..].
    iEpilogue "(HPC & Hi & Hr & Hr_t1) /="; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* geta r_t2 r *)
    iPrologue "Hprog".
    iApply (wp_Get_success with "[$HPC $Hi $Hr $Hr_t2]");
      [apply decode_encode_instrW_inv|auto|iCorrectPC link0 a_last|iContiguous_next Hcont 1|auto..].
    iEpilogue "(HPC & Hi & Hr & Hr_t2) /="; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* add r_t2 r_t2 paramsize *)
    iPrologue "Hprog".
    iApply (wp_add_sub_lt_success_dst_z with "[$HPC $Hi $Hr_t2]");
      [apply decode_encode_instrW_inv|auto|iContiguous_next Hcont 2|iCorrectPC link0 a_last|..].
    iEpilogue "(HPC & Hi & Hr_t2) /="; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* sub r_t1 r_t1 r_t2 *)
    iPrologue "Hprog".
    iApply (wp_add_sub_lt_success_dst_r with "[$HPC $Hi $Hr_t2 $Hr_t1]");
      [apply decode_encode_instrW_inv|auto|iContiguous_next Hcont 3|iCorrectPC link0 a_last|..].
    iEpilogue "(HPC & Hi & Hr_t2 & Hr_t1) /="; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* we need to distinguish between the case where the capability is stuck, or usable *)
    assert (∃ a_param, (b + paramsize)%a = Some a_param) as [a_param Ha_param].
    { destruct (b + paramsize)%a eqn:Hnone;eauto. exfalso. clear -Hnone Hsize. apply Z.ltb_lt in Hsize. solve_addr. }
    assert ((a' + (b - (a' - paramsize)))%a = Some a_param) as Hlea;[clear -Ha_param; solve_addr|].
    destruct (decide (a_param <= a')%a).
    2: { (* lea fail *)
      iPrologue "Hprog".
      iApply (wp_Lea_fail_U with "[$HPC $Hi $Hr_t1 $Hr]");
        [apply decode_encode_instrW_inv|iCorrectPC link0 a_last|apply Hlea|..].
      { simpl. solve_addr. }
      iEpilogue "_ /=". assert (b + paramsize <=? a' = false)%Z as ->;[apply Z.leb_gt;solve_addr|].
      iApply wp_value. iApply "Hφ". }
    (* lea r r_t1 *)
    iPrologue "Hprog".
    iApply (wp_lea_success_reg with "[$HPC $Hi $Hr_t1 $Hr]");
      [apply decode_encode_instrW_inv|iCorrectPC link0 a_last|iContiguous_next Hcont 4|apply Hlea|auto..].
    iEpilogue "(HPC & Hi & Hr_t1 & Hr)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t1 0 *)
    iPrologue "Hprog".
    iApply (wp_move_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC link0 a_last|iContiguous_next Hcont 5|auto|..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t2 0 *)
    iPrologue "Hprog".
    apply contiguous_between_last with (ai:=a5) in Hcont as Hlast;[|auto].
    iApply (wp_move_success_z with "[$HPC $Hi $Hr_t2]");
      [apply decode_encode_instrW_inv|iCorrectPC link0 a_last|apply Hlast|auto|..].
    iEpilogue "(HPC & Hi & Hr_t2)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    assert (b + paramsize <=? a' = true)%Z as ->;[apply Zle_is_le_bool;auto;clear -Ha_param l0;solve_addr|].
    iApply "Hφ". iFrame. iExists a_param. iSplit;auto. iFrame.
    repeat (iDestruct "Hprog_done" as "[Hi Hprog_done]"; iFrame "Hi").
    iFrame "Hprog_done". done.
  Qed.

End stack_macros.


From Undecidability.L Require Import LTactics Datatypes.Lists Datatypes.LNat Datatypes.LBool.
From Undecidability.TM Require TM ProgrammingTools CaseList CaseBool ListTM.

From Undecidability.TM Require Import TM_facts SizeBounds L.Transcode.BoollistEnc.

From Undecidability.L.Complexity  Require Import UpToCNary.

From Undecidability.L.AbstractMachines Require Import FlatPro.Programs.

Unset Printing Coercions.

From Undecidability.TM.L Require Alphabets.

From Coq Require Import Lia Ring Arith.

From Undecidability Require Import TM.Code.List.Concat_Repeat.

From Undecidability Require Import Cons_constant CaseCom CaseNat CaseList.

Set Default Proof Using "Type".

Module EncToBoollist.
  Section M.
    Import ProgrammingTools Combinators App CaseList CaseBool.
    Import Alphabets.

    Variable (sig : finType).
    (* Hypothesis (defX: inhabitedC sigX). *)

    (* We use the FinType instance of bool, as it has a Case-machine *)

    Context `{retr__list : Retract (sigList bool) sig}
            `{retr__Pro : Retract Alphabets.sigPro sig}.

    Local Instance retr__nat : Retract sigNat sig := ComposeRetract retr__Pro _.
    Local Instance retr__bool : Retract bool sig := ComposeRetract retr__list (Retract_sigList_X _).

    (* Check _ : codable sig (list bool). *)
    (* Check _ : codable sig bool. *)

    (* Tapes:
       0: compiled and encoded bs (input)
       1: result
       2: intern (constant for ConcatRepeat [0])
       3: intern (length of bs for concatReepat [1])
     *)

    (* für step (prepend the bs-dependent symbols)
               Tapes:
       0: bs (input)
       1: result
       2: head of bs
       3: intern (length of bs for concatReepat [1])
     *)

    Definition M__step : pTM sig^+ (option unit) 3 :=
      CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;Reset _ @ [|Fin2|];;
      CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;Reset _ @ [|Fin2|];;
      CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;
      CaseCom ⇑ ComposeRetract retr__Pro _ @ [|Fin2|];;
      If (CaseNat ⇑ _ @ [|Fin2|])
        (Return (Reset _ @ [|Fin2|];;
                 CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;Reset _ @ [|Fin2|];;
                 CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;Reset _ @ [|Fin2|]
              ) (Some tt))
        (Reset _ @ [|Fin2|];;
         CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;Reset _ @ [|Fin2|];;
         CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;Reset _ @ [|Fin2|];;
         CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;
         CaseCom ⇑ ComposeRetract retr__Pro _ @ [|Fin2|];;
         Switch (CaseNat ⇑ _ @ [|Fin2|])
          (fun b => Cons_constant.M b ⇑ retr__list @[|Fin1|]);;
          Reset _ @ [|Fin2|];;
          CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;Reset _ @ [|Fin2|];;
          CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;Reset _ @ [|Fin2|];;
          CaseList _ ⇑ retr__Pro @ [|Fin0;Fin2|];;Reset _ @ [|Fin2|];;
          Return Nop (None)
        ).

    Import Hoare.

    Lemma SpecT__step :
    { f : UpToC (fun bs => 1) &
    forall (bs res :list bool) (n:nat),
      TripleT
        ≃≃([],[|Contains _ (flat_map enc_bool_perElem bs ++ enc_bool_nil ++ concat (repeat enc_bool_closing n));
                Contains _ res;Void|])
        (f bs)
        M__step
        (fun y => ≃≃([y = match bs with [] => Some tt | _ => None end]
          ,match bs with
          | [] => [| Contains _ (concat (repeat enc_bool_closing (n + length bs)));Contains _ res;Void |]
          | b::bs' => [|Contains _ (flat_map enc_bool_perElem bs' ++ enc_bool_nil ++ concat (repeat enc_bool_closing n));Contains _ (b::res);Void|]
          end)) }.
    Proof.
      evar (c1 : nat);evar (c2 :nat).
      exists_UpToC (fun bs => max c1 c2). 2:now smpl_upToC_solve.
      intros bs res n.
      unfold M__step. rewrite app_assoc,enc_boollist_helper.
      hstep. 3:shelve. now (hsteps_cbn;cbn;tspec_ext). cbn. hintros ? ->.
      do 5 ((hstep;cbn);[hsteps_cbn;cbn;tspec_ext| cbn;hintros;first [ intros ? ->|intros ** ] |reflexivity]).
      clear H.
      refine (_ : TripleT _ (match bs with [] => _ | _ => _ end) _ _).
      hstep.
      -cbn;hsteps_cbn. tspec_ext. cbn. eassumption.
      -cbn. destruct bs; hintros ?. 2:nia.
      hsteps_cbn. now tspec_ext. 2-3:reflexivity.
      cbn. hintros ? ->. hsteps_cbn;cbn. tspec_ext. cbn. 2-3:reflexivity. hintros ? ->.
      now hsteps_cbn. cbn. rewrite Nat.add_0_r. tspec_ext.
      - cbn.
        refine (_ : TripleT _ match bs with [] => _ | b::bs => _ end _ _).
        destruct bs; hintros ?. nia.
        hsteps_cbn. now tspec_ext. 2-3:unfold CaseList_steps; cbn;reflexivity.
        cbn. hintros ? ->.
        hsteps_cbn. now tspec_ext. 2-3:unfold CaseList_steps; cbn;reflexivity.
        cbn. hintros ? ->.
        hsteps_cbn. now tspec_ext. 3:reflexivity.
        2:{
          unfold CaseList_steps,CaseList_steps_cons. rewrite Encode_Com_hasSize.
          unfold Encode_Com_size. rewrite Encode_sum_hasSize;cbn -["+" "*"].
          set (m := length _). assert (m<= 2) by now (subst m;destruct b;cbn).
          rewrite H0. reflexivity.
        }
        cbn. hintros ? ->.
        hsteps_cbn;cbn. now tspec_ext. 2:reflexivity.
        hintros y Hy.
        destruct y.
        {exfalso. destruct a;inv Hy. }
        destruct Hy as (?&[=<-]).
        hsteps_cbn;cbn.
        now tspec_ext. 2,6,7,8:reflexivity.
        {
          hintros y Hy.
          replace y with b. 2:{destruct b,y;cbn in Hy. all:easy. } clear Hy.
          hsteps_cbn;cbn. tspec_ext.
        }
        {cbn. hsteps_cbn. }
        {cbn. hsteps_cbn. cbn. reflexivity. }
        cbn. hintros ? ->.
        hsteps_cbn. now tspec_ext. 2,3:unfold CaseList_steps;cbn;reflexivity.
        cbn. hintros ? ->.
        hsteps_cbn. now tspec_ext. 2,3:unfold CaseList_steps;cbn;reflexivity.
        cbn. hintros ? ->.
        hsteps_cbn. 2:reflexivity.
        tspec_ext. f_equal. unfold enc_bool_nil;cbn;autorewrite with list . reflexivity.
      - cbn - ["+" "*"].
        intros b Hb.
        destruct b,bs; try (exfalso;nia). all:reflexivity.
      Unshelve.
      3:{
      destruct bs.
      + rewrite <- Nat.le_max_r. now cbv.
      + rewrite <- Nat.le_max_l. unfold Cons_constant.time,CaseList_steps,Reset_steps.
        ring_simplify. unshelve erewrite (_ : size (Init.Nat.pred (if b then 1 else 0))<= 1). {now destruct b;cbv. }
        unshelve erewrite (_ : size b<= 1). {now destruct b;cbv. }
        unfold c1. reflexivity.
      }
      exact 0.
    Qed.

    Arguments rcomp : simpl never.

    Definition M__loop : pTM sig^+ unit 3 := While M__step.

    Lemma SpecT__loop :
    { f : UpToC (fun bs => length bs + 1) &
    forall (bs res :list bool) (n:nat),
      TripleT
        ≃≃([],[|Contains _ (flat_map enc_bool_perElem bs ++ enc_bool_nil ++ concat (repeat enc_bool_closing n));
                Contains _ res;Void|])
        (f bs)
        M__loop
        (fun _ => ≃≃([],[| Contains _ (concat (repeat enc_bool_closing n));Contains _  (rev bs ++res);Void |]))}.
    Proof.
      evar (c1 : nat);evar (c2 :nat).
      exists_UpToC (fun bs => c1 * length bs + c2). 2:now smpl_upToC_solve.
      intros bs res n.
      unfold M__loop.
      eapply While_SpecTReg with
      (PRE := fun '(bs,res) => (_,_)) (INV := fun '(bs,res) y => (_,_)) (POST := fun '(bs,res) y => (_,_))
        (f__step := fun '(bs,res) => _) (f__loop := fun '(bs,res) => _) (x := (bs,res));
        clear bs res; intros (bs,res); cbn in *. eapply (projT2 SpecT__step).
      cbn. split.
      -intros ? Hbs. destruct bs. 2:easy.
      cbn. split. { rewrite Nat.add_0_r. reflexivity. } rewrite Nat.mul_0_r;cbn. unfold c2;reflexivity.
      -destruct bs. easy. intros _.
      eexists (_,_). cbn.
      split. reflexivity. split. 2:autorewrite with list;cbn;reflexivity.
      rewrite UpToC_le.
      ring_simplify.
      [c1]:exact (1 + c__leUpToC (H:=projT1 SpecT__step)).
      unfold c1. lia.
    Qed.

    Import ListTM.

    Definition M : pTM sig^+ unit 3 :=
      WriteValue ( (nil:list bool)) ⇑ _ @ [|Fin1|];;
      M__loop.

    Lemma SpecT :
    { f : UpToC (fun bs => length bs + 1) &
    forall (bs :list bool),
      TripleT
        ≃≃([],[|Contains _ (compile (enc bs));
                Void;Void|])
        (f bs)
        M
        (fun _ => ≃≃([],[| Contains _ (concat (repeat enc_bool_closing (length bs)));Contains _  (rev bs);Void |]))}.
    Proof.
      unfold M.
      eexists_UpToC f.
      intros. rewrite enc_bool_explicit.
      hsteps_cbn;cbn. reflexivity.
      {
        eapply ConsequenceT. eapply (projT2 SpecT__loop) with (n:=length bs) (res:=[]).
        all:cbn. now tspec_ext. now rewrite app_nil_r. reflexivity.
      }
      [f]:intros bs. ring_simplify.
      unfold f;reflexivity.
      subst f.
      smpl_upToC_solve.
    Qed.

  End M.
End EncToBoollist.
Arguments EncToBoollist.M : clear implicits.
Arguments EncToBoollist.M {_} _ _.