(* *********************************************************************)
(*                                                                     *)
(*              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 GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** This file defines a number of data types and operations used in
  the abstract syntax trees of many of the intermediate languages. *)

Require Import String.
Require Import Coqlib Maps Errors Integers Floats.
Require Archi.

Set Implicit Arguments.

(** * Syntactic elements *)

(** Identifiers (names of local variables, of global symbols and functions,
  etc) are represented by the type [positive] of positive integers. *)

Definition ident := positive.

Definition ident_eq := peq.

(** The intermediate languages are weakly typed, using the following types: *)

Inductive typ : Type :=
  | Tint                (**r 32-bit integers or pointers *)
  | Tfloat              (**r 64-bit double-precision floats *)
  | Tlong               (**r 64-bit integers *)
  | Tsingle             (**r 32-bit single-precision floats *)
  | Tany32              (**r any 32-bit value *)
  | Tany64.             (**r any 64-bit value, i.e. any value *)

Lemma typ_eq: forall (t1 t2: typ), {t1=t2} + {t1<>t2}.
Proof. decide equality. Defined.
Global Opaque typ_eq.

Definition opt_typ_eq: forall (t1 t2: option typ), {t1=t2} + {t1<>t2}
                     := option_eq typ_eq.

Definition list_typ_eq: forall (l1 l2: list typ), {l1=l2} + {l1<>l2}
                     := list_eq_dec typ_eq.

Definition Tptr : typ := if Archi.ptr64 then Tlong else Tint.

Definition typesize (ty: typ) : Z :=
  match ty with
  | Tint => 4
  | Tfloat => 8
  | Tlong => 8
  | Tsingle => 4
  | Tany32 => 4
  | Tany64 => 8
  end.

Lemma typesize_pos: forall ty, typesize ty > 0.
Proof. destruct ty; simpl; omega. Qed.

Lemma typesize_Tptr: typesize Tptr = if Archi.ptr64 then 8 else 4.
Proof. unfold Tptr; destruct Archi.ptr64; auto. Qed.

(** All values of size 32 bits are also of type [Tany32].  All values
  are of type [Tany64].  This corresponds to the following subtyping
  relation over types. *)

Definition subtype (ty1 ty2: typ) : bool :=
  match ty1, ty2 with
  | Tint, Tint => true
  | Tlong, Tlong => true
  | Tfloat, Tfloat => true
  | Tsingle, Tsingle => true
  | (Tint | Tsingle | Tany32), Tany32 => true
  | _, Tany64 => true
  | _, _ => false
  end.

Fixpoint subtype_list (tyl1 tyl2: list typ) : bool :=
  match tyl1, tyl2 with
  | nil, nil => true
  | ty1::tys1, ty2::tys2 => subtype ty1 ty2 && subtype_list tys1 tys2
  | _, _ => false
  end.

(** Additionally, function definitions and function calls are annotated
  by function signatures indicating:
- the number and types of arguments;
- the type of the returned value, if any;
- additional information on which calling convention to use.

These signatures are used in particular to determine appropriate
calling conventions for the function. *)

Record calling_convention : Type := mkcallconv {
  cc_vararg: bool;                      (**r variable-arity function *)
  cc_unproto: bool;                     (**r old-style unprototyped function *)
  cc_structret: bool                    (**r function returning a struct  *)
}.

Definition cc_default :=
  {| cc_vararg := false; cc_unproto := false; cc_structret := false |}.

Definition calling_convention_eq (x y: calling_convention) : {x=y} + {x<>y}.
Proof.
  decide equality; apply bool_dec.
Defined.
Global Opaque calling_convention_eq.

Record signature : Type := mksignature {
  sig_args: list typ;
  sig_res: option typ;
  sig_cc: calling_convention
}.

Definition proj_sig_res (s: signature) : typ :=
  match s.(sig_res) with
  | None => Tint
  | Some t => t
  end.

Definition signature_eq: forall (s1 s2: signature), {s1=s2} + {s1<>s2}.
Proof.
  generalize opt_typ_eq, list_typ_eq, calling_convention_eq; decide equality.
Defined.
Global Opaque signature_eq.

Definition signature_main :=
  {| sig_args := nil; sig_res := Some Tint; sig_cc := cc_default |}.

(** Memory accesses (load and store instructions) are annotated by
  a ``memory chunk'' indicating the type, size and signedness of the
  chunk of memory being accessed. *)

Inductive memory_chunk : Type :=
  | Mint8signed     (**r 8-bit signed integer *)
  | Mint8unsigned   (**r 8-bit unsigned integer *)
  | Mint16signed    (**r 16-bit signed integer *)
  | Mint16unsigned  (**r 16-bit unsigned integer *)
  | Mint32          (**r 32-bit integer, or pointer *)
  | Mint64          (**r 64-bit integer *)
  | Mfloat32        (**r 32-bit single-precision float *)
  | Mfloat64        (**r 64-bit double-precision float *)
  | Many32          (**r any value that fits in 32 bits *)
  | Many64.         (**r any value *)

Definition chunk_eq: forall (c1 c2: memory_chunk), {c1=c2} + {c1<>c2}.
Proof. decide equality. Defined.
Global Opaque chunk_eq.

Definition Mptr : memory_chunk := if Archi.ptr64 then Mint64 else Mint32.

(** The type (integer/pointer or float) of a chunk. *)

Definition type_of_chunk (c: memory_chunk) : typ :=
  match c with
  | Mint8signed => Tint
  | Mint8unsigned => Tint
  | Mint16signed => Tint
  | Mint16unsigned => Tint
  | Mint32 => Tint
  | Mint64 => Tlong
  | Mfloat32 => Tsingle
  | Mfloat64 => Tfloat
  | Many32 => Tany32
  | Many64 => Tany64
  end.

Lemma type_of_Mptr: type_of_chunk Mptr = Tptr.
Proof. unfold Mptr, Tptr; destruct Archi.ptr64; auto. Qed.

(** The chunk that is appropriate to store and reload a value of
  the given type, without losing information. *)

Definition chunk_of_type (ty: typ) :=
  match ty with
  | Tint => Mint32
  | Tfloat => Mfloat64
  | Tlong => Mint64
  | Tsingle => Mfloat32
  | Tany32 => Many32
  | Tany64 => Many64
  end.

Lemma chunk_of_Tptr: chunk_of_type Tptr = Mptr.
Proof. unfold Mptr, Tptr; destruct Archi.ptr64; auto. Qed.

(** Initialization data for global variables. *)

Inductive init_data: Type :=
  | Init_int8: int -> init_data
  | Init_int16: int -> init_data
  | Init_int32: int -> init_data
  | Init_int64: int64 -> init_data
  | Init_float32: float32 -> init_data
  | Init_float64: float -> init_data
  | Init_space: Z -> init_data
  | Init_addrof: ident -> ptrofs -> init_data.  (**r address of symbol + offset *)

Definition init_data_size (i: init_data) : Z :=
  match i with
  | Init_int8 _ => 1
  | Init_int16 _ => 2
  | Init_int32 _ => 4
  | Init_int64 _ => 8
  | Init_float32 _ => 4
  | Init_float64 _ => 8
  | Init_addrof _ _ => if Archi.ptr64 then 8 else 4
  | Init_space n => Z.max n 0
  end.

Fixpoint init_data_list_size (il: list init_data) {struct il} : Z :=
  match il with
  | nil => 0
  | i :: il' => init_data_size i + init_data_list_size il'
  end.

Lemma init_data_size_pos:
  forall i, init_data_size i >= 0.
Proof.
  destruct i; simpl; try xomega. destruct Archi.ptr64; omega.
Qed.

Lemma init_data_list_size_pos:
  forall il, init_data_list_size il >= 0.
Proof.
  induction il; simpl. omega. generalize (init_data_size_pos a); omega.
Qed.

(** Information attached to global variables. *)

Record globvar (V: Type) : Type := mkglobvar {
  gvar_info: V;                    (**r language-dependent info, e.g. a type *)
  gvar_init: list init_data;       (**r initialization data *)
  gvar_readonly: bool;             (**r read-only variable? (const) *)
  gvar_volatile: bool              (**r volatile variable? *)
}.

(** Whole programs consist of:
- a collection of global definitions (name and description);
- a set of public names (the names that are visible outside
  this compilation unit);
- the name of the ``main'' function that serves as entry point in the program.

A global definition is either a global function or a global variable.
The type of function descriptions and that of additional information
for variables vary among the various intermediate languages and are
taken as parameters to the [program] type.  The other parts of whole
programs are common to all languages. *)

Inductive globdef (F V: Type) : Type :=
  | Gfun (f: F)
  | Gvar (v: globvar V).

Arguments Gfun [F V].
Arguments Gvar [F V].

Record program (F V: Type) : Type := mkprogram {
  prog_defs: list (ident * globdef F V);
  prog_public: list ident;
  prog_main: ident
}.

Definition prog_defs_names (F V: Type) (p: program F V) : list ident :=
  List.map fst p.(prog_defs).

(** The "definition map" of a program maps names of globals to their definitions.
  If several definitions have the same name, the one appearing last in [p.(prog_defs)] wins. *)

Definition prog_defmap (F V: Type) (p: program F V) : PTree.t (globdef F V) :=
  PTree_Properties.of_list p.(prog_defs).

Section DEFMAP.

Variables F V: Type.
Variable p: program F V.

Lemma in_prog_defmap:
  forall id g, (prog_defmap p)!id = Some g -> In (id, g) (prog_defs p).
Proof.
  apply PTree_Properties.in_of_list.
Qed.

Lemma prog_defmap_dom:
  forall id, In id (prog_defs_names p) -> exists g, (prog_defmap p)!id = Some g.
Proof.
  apply PTree_Properties.of_list_dom.
Qed.

Lemma prog_defmap_unique:
  forall defs1 id g defs2,
  prog_defs p = defs1 ++ (id, g) :: defs2 ->
  ~In id (map fst defs2) ->
  (prog_defmap p)!id = Some g.
Proof.
  unfold prog_defmap; intros. rewrite H. apply PTree_Properties.of_list_unique; auto.
Qed.

Lemma prog_defmap_norepet:
  forall id g,
  list_norepet (prog_defs_names p) ->
  In (id, g) (prog_defs p) ->
  (prog_defmap p)!id = Some g.
Proof.
  apply PTree_Properties.of_list_norepet.
Qed.

End DEFMAP.

(** * Generic transformations over programs *)

(** We now define a general iterator over programs that applies a given
  code transformation function to all function descriptions and leaves
  the other parts of the program unchanged. *)

Section TRANSF_PROGRAM.

Variable A B V: Type.
Variable transf: A -> B.

Definition transform_program_globdef (idg: ident * globdef A V) : ident * globdef B V :=
  match idg with
  | (id, Gfun f) => (id, Gfun (transf f))
  | (id, Gvar v) => (id, Gvar v)
  end.

Definition transform_program (p: program A V) : program B V :=
  mkprogram
    (List.map transform_program_globdef p.(prog_defs))
    p.(prog_public)
    p.(prog_main).

End TRANSF_PROGRAM.

(** The following is a more general presentation of [transform_program]:
- Global variable information can be transformed, in addition to function
  definitions.
- The transformation functions can fail and return an error message.
- The transformation for function definitions receives a global context
  (derived from the compilation unit being transformed) as additiona
  argument.
- The transformation functions receive the name of the global as
  additional argument. *)

Local Open Scope error_monad_scope.

Section TRANSF_PROGRAM_GEN.

Variables A B V W: Type.
Variable transf_fun: ident -> A -> res B.
Variable transf_var: ident -> V -> res W.

Definition transf_globvar (i: ident) (g: globvar V) : res (globvar W) :=
  do info' <- transf_var i g.(gvar_info);
  OK (mkglobvar info' g.(gvar_init) g.(gvar_readonly) g.(gvar_volatile)).

Fixpoint transf_globdefs (l: list (ident * globdef A V)) : res (list (ident * globdef B W)) :=
  match l with
  | nil => OK nil
  | (id, Gfun f) :: l' =>
    match transf_fun id f with
      | Error msg => Error (MSG "In function " :: CTX id :: MSG ": " :: msg)
      | OK tf =>
        do tl' <- transf_globdefs l'; OK ((id, Gfun tf) :: tl')
    end
  | (id, Gvar v) :: l' =>
    match transf_globvar id v with
      | Error msg => Error (MSG "In variable " :: CTX id :: MSG ": " :: msg)
      | OK tv =>
        do tl' <- transf_globdefs l'; OK ((id, Gvar tv) :: tl')
    end
  end.

Definition transform_partial_program2 (p: program A V) : res (program B W) :=
  do gl' <- transf_globdefs p.(prog_defs);
  OK (mkprogram gl' p.(prog_public) p.(prog_main)).

End TRANSF_PROGRAM_GEN.

(** The following is a special case of [transform_partial_program2],
  where only function definitions are transformed, but not variable definitions. *)

Section TRANSF_PARTIAL_PROGRAM.

Variable A B V: Type.
Variable transf_fun: A -> res B.

Definition transform_partial_program (p: program A V) : res (program B V) :=
  transform_partial_program2 (fun i f => transf_fun f) (fun i v => OK v) p.

End TRANSF_PARTIAL_PROGRAM.

Lemma transform_program_partial_program:
  forall (A B V: Type) (transf_fun: A -> B) (p: program A V),
  transform_partial_program (fun f => OK (transf_fun f)) p = OK (transform_program transf_fun p).
Proof.
  intros. unfold transform_partial_program, transform_partial_program2.
  assert (EQ: forall l,
              transf_globdefs (fun i f => OK (transf_fun f)) (fun i (v: V) => OK v) l =
              OK (List.map (transform_program_globdef transf_fun) l)).
  { induction l as [ | [id g] l]; simpl.
  - auto.
  - destruct g; simpl; rewrite IHl; simpl. auto. destruct v; auto.
  }
  rewrite EQ; simpl. auto.
Qed.

(** * External functions *)

(** For most languages, the functions composing the program are either
  internal functions, defined within the language, or external functions,
  defined outside.  External functions include system calls but also
  compiler built-in functions.  We define a type for external functions
  and associated operations. *)

Inductive external_function : Type :=
  | EF_external (name: string) (sg: signature)
     (** A system call or library function.  Produces an event
         in the trace. *)
  | EF_builtin (name: string) (sg: signature)
     (** A compiler built-in function.  Behaves like an external, but
         can be inlined by the compiler. *)
  | EF_runtime (name: string) (sg: signature)
     (** A function from the run-time library.  Behaves like an
         external, but must not be redefined. *)
  | EF_vload (chunk: memory_chunk)
     (** A volatile read operation.  If the adress given as first argument
         points within a volatile global variable, generate an
         event and return the value found in this event.  Otherwise,
         produce no event and behave like a regular memory load. *)
  | EF_vstore (chunk: memory_chunk)
     (** A volatile store operation.   If the adress given as first argument
         points within a volatile global variable, generate an event.
         Otherwise, produce no event and behave like a regular memory store. *)
  | EF_malloc
     (** Dynamic memory allocation.  Takes the requested size in bytes
         as argument; returns a pointer to a fresh block of the given size.
         Produces no observable event. *)
  | EF_free
     (** Dynamic memory deallocation.  Takes a pointer to a block
         allocated by an [EF_malloc] external call and frees the
         corresponding block.
         Produces no observable event. *)
  | EF_memcpy (sz: Z) (al: Z)
     (** Block copy, of [sz] bytes, between addresses that are [al]-aligned. *)
  | EF_annot (kind: positive) (text: string) (targs: list typ)
     (** A programmer-supplied annotation.  Takes zero, one or several arguments,
         produces an event carrying the text and the values of these arguments,
         and returns no value. *)
  | EF_annot_val (kind: positive) (text: string) (targ: typ)
     (** Another form of annotation that takes one argument, produces
         an event carrying the text and the value of this argument,
         and returns the value of the argument. *)
  | EF_inline_asm (text: string) (sg: signature) (clobbers: list string)
     (** Inline [asm] statements.  Semantically, treated like an
         annotation with no parameters ([EF_annot text nil]).  To be
         used with caution, as it can invalidate the semantic
         preservation theorem.  Generated only if [-finline-asm] is
         given. *)
  | EF_debug (kind: positive) (text: ident) (targs: list typ).
     (** Transport debugging information from the front-end to the generated
         assembly.  Takes zero, one or several arguments like [EF_annot].
         Unlike [EF_annot], produces no observable event. *)

(** The type signature of an external function. *)

Definition ef_sig (ef: external_function): signature :=
  match ef with
  | EF_external name sg => sg
  | EF_builtin name sg => sg
  | EF_runtime name sg => sg
  | EF_vload chunk => mksignature (Tptr :: nil) (Some (type_of_chunk chunk)) cc_default
  | EF_vstore chunk => mksignature (Tptr :: type_of_chunk chunk :: nil) None cc_default
  | EF_malloc => mksignature (Tptr :: nil) (Some Tptr) cc_default
  | EF_free => mksignature (Tptr :: nil) None cc_default
  | EF_memcpy sz al => mksignature (Tptr :: Tptr :: nil) None cc_default
  | EF_annot kind text targs => mksignature targs None cc_default
  | EF_annot_val kind text targ => mksignature (targ :: nil) (Some targ) cc_default
  | EF_inline_asm text sg clob => sg
  | EF_debug kind text targs => mksignature targs None cc_default
  end.

(** Whether an external function should be inlined by the compiler. *)

Definition ef_inline (ef: external_function) : bool :=
  match ef with
  | EF_external name sg => false
  | EF_builtin name sg => true
  | EF_runtime name sg => false
  | EF_vload chunk => true
  | EF_vstore chunk => true
  | EF_malloc => false
  | EF_free => false
  | EF_memcpy sz al => true
  | EF_annot kind text targs => true
  | EF_annot_val kind Text rg => true
  | EF_inline_asm text sg clob => true
  | EF_debug kind text targs => true
  end.

(** Whether an external function must reload its arguments. *)

Definition ef_reloads (ef: external_function) : bool :=
  match ef with
  | EF_annot kind text targs => false
  | EF_debug kind text targs => false
  | _ => true
  end.

(** Equality between external functions.  Used in module [Allocation]. *)

Definition external_function_eq: forall (ef1 ef2: external_function), {ef1=ef2} + {ef1<>ef2}.
Proof.
  generalize ident_eq string_dec signature_eq chunk_eq typ_eq list_eq_dec zeq Int.eq_dec; intros.
  decide equality.
Defined.
Global Opaque external_function_eq.

(** Function definitions are the union of internal and external functions. *)

Inductive fundef (F: Type): Type :=
  | Internal: F -> fundef F
  | External: external_function -> fundef F.

Arguments External [F].

Section TRANSF_FUNDEF.

Variable A B: Type.
Variable transf: A -> B.

Definition transf_fundef (fd: fundef A): fundef B :=
  match fd with
  | Internal f => Internal (transf f)
  | External ef => External ef
  end.

End TRANSF_FUNDEF.

Section TRANSF_PARTIAL_FUNDEF.

Variable A B: Type.
Variable transf_partial: A -> res B.

Definition transf_partial_fundef (fd: fundef A): res (fundef B) :=
  match fd with
  | Internal f => do f' <- transf_partial f; OK (Internal f')
  | External ef => OK (External ef)
  end.

End TRANSF_PARTIAL_FUNDEF.

(** * Register pairs *)

Set Contextual Implicit.

(** In some intermediate languages (LTL, Mach), 64-bit integers can be
  split into two 32-bit halves and held in a pair of registers.
  Syntactically, this is captured by the type [rpair] below. *)

Inductive rpair (A: Type) : Type :=
  | One (r: A)
  | Twolong (rhi rlo: A).

Definition typ_rpair (A: Type) (typ_of: A -> typ) (p: rpair A): typ :=
  match p with
  | One r => typ_of r
  | Twolong rhi rlo => Tlong
  end.

Definition map_rpair (A B: Type) (f: A -> B) (p: rpair A): rpair B :=
  match p with
  | One r => One (f r)
  | Twolong rhi rlo => Twolong (f rhi) (f rlo)
  end.

Definition regs_of_rpair (A: Type) (p: rpair A): list A :=
  match p with
  | One r => r :: nil
  | Twolong rhi rlo => rhi :: rlo :: nil
  end.

Fixpoint regs_of_rpairs (A: Type) (l: list (rpair A)): list A :=
  match l with
  | nil => nil
  | p :: l => regs_of_rpair p ++ regs_of_rpairs l
  end.

Lemma in_regs_of_rpairs:
  forall (A: Type) (x: A) p, In x (regs_of_rpair p) -> forall l, In p l -> In x (regs_of_rpairs l).
Proof.
  induction l; simpl; intros. auto. apply in_app. destruct H0; auto. subst a. auto.
Qed.

Lemma in_regs_of_rpairs_inv:
  forall (A: Type) (x: A) l, In x (regs_of_rpairs l) -> exists p, In p l /\ In x (regs_of_rpair p).
Proof.
  induction l; simpl; intros. contradiction.
  rewrite in_app_iff in H; destruct H.
  exists a; auto.
  apply IHl in H. firstorder auto.
Qed.

Definition forall_rpair (A: Type) (P: A -> Prop) (p: rpair A): Prop :=
  match p with
  | One r => P r
  | Twolong rhi rlo => P rhi /\ P rlo
  end.

(** * Arguments and results to builtin functions *)

Inductive builtin_arg (A: Type) : Type :=
  | BA (x: A)
  | BA_int (n: int)
  | BA_long (n: int64)
  | BA_float (f: float)
  | BA_single (f: float32)
  | BA_loadstack (chunk: memory_chunk) (ofs: ptrofs)
  | BA_addrstack (ofs: ptrofs)
  | BA_loadglobal (chunk: memory_chunk) (id: ident) (ofs: ptrofs)
  | BA_addrglobal (id: ident) (ofs: ptrofs)
  | BA_splitlong (hi lo: builtin_arg A)
  | BA_addptr (a1 a2: builtin_arg A).

Inductive builtin_res (A: Type) : Type :=
  | BR (x: A)
  | BR_none
  | BR_splitlong (hi lo: builtin_res A).

Fixpoint globals_of_builtin_arg (A: Type) (a: builtin_arg A) : list ident :=
  match a with
  | BA_loadglobal chunk id ofs => id :: nil
  | BA_addrglobal id ofs => id :: nil
  | BA_splitlong hi lo => globals_of_builtin_arg hi ++ globals_of_builtin_arg lo
  | BA_addptr a1 a2 => globals_of_builtin_arg a1 ++ globals_of_builtin_arg a2
  | _ => nil
  end.

Definition globals_of_builtin_args (A: Type) (al: list (builtin_arg A)) : list ident :=
  List.fold_right (fun a l => globals_of_builtin_arg a ++ l) nil al.

Fixpoint params_of_builtin_arg (A: Type) (a: builtin_arg A) : list A :=
  match a with
  | BA x => x :: nil
  | BA_splitlong hi lo => params_of_builtin_arg hi ++ params_of_builtin_arg lo
  | BA_addptr a1 a2 => params_of_builtin_arg a1 ++ params_of_builtin_arg a2
  | _ => nil
  end.

Definition params_of_builtin_args (A: Type) (al: list (builtin_arg A)) : list A :=
  List.fold_right (fun a l => params_of_builtin_arg a ++ l) nil al.

Fixpoint params_of_builtin_res (A: Type) (a: builtin_res A) : list A :=
  match a with
  | BR x => x :: nil
  | BR_none => nil
  | BR_splitlong hi lo => params_of_builtin_res hi ++ params_of_builtin_res lo
  end.

Fixpoint map_builtin_arg (A B: Type) (f: A -> B) (a: builtin_arg A) : builtin_arg B :=
  match a with
  | BA x => BA (f x)
  | BA_int n => BA_int n
  | BA_long n => BA_long n
  | BA_float n => BA_float n
  | BA_single n => BA_single n
  | BA_loadstack chunk ofs => BA_loadstack chunk ofs
  | BA_addrstack ofs => BA_addrstack ofs
  | BA_loadglobal chunk id ofs => BA_loadglobal chunk id ofs
  | BA_addrglobal id ofs => BA_addrglobal id ofs
  | BA_splitlong hi lo =>
      BA_splitlong (map_builtin_arg f hi) (map_builtin_arg f lo)
  | BA_addptr a1 a2 =>
      BA_addptr (map_builtin_arg f a1) (map_builtin_arg f a2)
  end.

Fixpoint map_builtin_res (A B: Type) (f: A -> B) (a: builtin_res A) : builtin_res B :=
  match a with
  | BR x => BR (f x)
  | BR_none => BR_none
  | BR_splitlong hi lo =>
      BR_splitlong (map_builtin_res f hi) (map_builtin_res f lo)
  end.

(** Which kinds of builtin arguments are supported by which external function. *)

Inductive builtin_arg_constraint : Type :=
  | OK_default
  | OK_const
  | OK_addrstack
  | OK_addressing
  | OK_all.


From PetitC Require Import Codegen Asm TypedTree Memory Output Semantics AsmSemantics SemanticsLemmas
                           MemoryEquivalence Values Ids Monad Star Tactics Sublist.
Import TypedTree. (* why do i have to import TypedTree? all the definitions are on top level there *)

From Coq Require Import Lists.List Nat ZArith Program.Utils Wellfounded Nat Lia.
Import ListNotations.
Open Scope nat.

Section CodegenLemmas.

Variables (funcs : list (func_id * func))
          (func_labels : FuncIdMap.t label)
          (func_depths : FuncIdMap.t nat)
          (var_rbp_offsets : VarIdMap.t offset)
          (var_depths : VarIdMap.t nat).

Definition toplevel_accessible_var_ids_opt (func_id : func_id) : option (list var_id) :=
  assoc func_id funcs >>= fun func =>
  Some ((f_local_var_ids func) ++ (f_arg_var_ids func)).

Fixpoint toplevel_accessible_var_ids_opt_of_list (func_ids : list func_id) :
           option (list var_id) :=
  match func_ids with
  | id::ids => toplevel_accessible_var_ids_opt id >>= fun func_var_ids =>
               toplevel_accessible_var_ids_opt_of_list ids >>= fun func_var_ids' =>
               Some (func_var_ids ++ func_var_ids')
  | []      => Some []
  end.

Definition accessible_var_ids_opt (func_id : func_id) : option (list var_id) :=
  assoc func_id funcs >>= fun func =>
  toplevel_accessible_var_ids_opt func_id >>= fun var_ids =>
  toplevel_accessible_var_ids_opt_of_list (f_parent_func_ids func) >>= fun parent_var_ids =>
  Some (var_ids ++ parent_var_ids).

Definition accessible_var_ids (func_id : func_id) (var_ids : list var_id) :=
  accessible_var_ids_opt func_id = Some var_ids.

Definition parent_rbp (stack : stack) (rbp : offset) (parent_rbp : offset) : Prop :=
  OffsetMap.find (rbp + Z.of_nat word_size)%Z stack = Some (PtrValue (StackPtr parent_rbp)).

Inductive ancestor_rbp (stack : stack) : nat -> offset -> offset -> Prop :=
  | ARZero (rbp : offset) :
      ancestor_rbp stack 0%nat rbp rbp
  | ARSucc (depth : nat) (rbp parent_rbp' ancestor_rbp' : offset) : (* primes to avoid name clashes *)
        parent_rbp stack rbp parent_rbp' ->
        ancestor_rbp stack depth parent_rbp' ancestor_rbp' ->
      ancestor_rbp stack (S depth) rbp ancestor_rbp'.

Definition asm_var_ptr (stack : stack) (rbp : offset)
                            (var_id : var_id) (ptr : ptr_value) : Prop :=
  exists depth ancestor_rbp' rbp_offset,
    VarIdMap.find var_id var_depths = Some depth /\
    VarIdMap.find var_id var_rbp_offsets = Some rbp_offset /\
    ancestor_rbp stack depth rbp ancestor_rbp' /\
    ptr = StackPtr (ancestor_rbp' + rbp_offset)%Z.

Definition asm_accessible_var_ptrs (stack : stack) (rbp : offset) (func_id : func_id)
                                        (var_ptrs : VarIdMap.t ptr_value) : Prop :=
  exists var_ids, accessible_var_ids func_id var_ids /\
                  (forall var_id, In var_id var_ids <-> VarIdMap.In var_id var_ptrs) /\
                  forall var_id ptr, VarIdMap.find var_id var_ptrs = Some ptr ->
                                     asm_var_ptr stack rbp var_id ptr.

Definition VarIdMap_combine {X Y : Type}
                            (m : VarIdMap.t X) (m' : VarIdMap.t Y) (l : list (X * Y)) : Prop :=
  NoDup l /\
  (forall id, VarIdMap.In id m <-> VarIdMap.In id m') /\
  (forall x y, In (x, y) l <->
                exists id, VarIdMap.find id m = Some x /\ VarIdMap.find id m' = Some y).

Definition states_equivalent (rbp : offset) (func_id : func_id) (c_var_ptrs : VarIdMap.t ptr_value)
                             (c_state asm_state : memory * output) : Prop :=
  let '(c_mem, c_out) := c_state in
  let '((asm_stack, asm_heap) as asm_mem, asm_out) := asm_state in
  c_out = asm_out /\
  exists asm_var_ptrs,
    asm_accessible_var_ptrs asm_stack rbp func_id asm_var_ptrs /\
    (forall var_id, VarIdMap.In var_id c_var_ptrs <-> VarIdMap.In var_id asm_var_ptrs) /\
    exists corresponding_ptrs,
      VarIdMap_combine c_var_ptrs asm_var_ptrs corresponding_ptrs /\
      accessible_equivalent corresponding_ptrs c_mem asm_mem.

(* Definition compile_cmd' (args : compile_args) (depth : nat) (cmd : cmd)
                        (break_lbl continue_lbl : label) (label_counter : label_counter) :
                        option asm :=
  let compiled := compile_cmd (ca_func_depths args) depth (ca_var_rbp_offsets args)
                              (ca_var_depths args) break_lbl continue_lbl cmd [] label_counter in
  match compiled with
  | (Some asm, _) => Some asm
  | (None, _)     => None
  end. *)

Lemma compile_cmd_eq_cons_tail_asm fd d vro vd bl cl lc lc' cmd tail_asm asm_app_tail :
  compile_cmd fd d vro vd bl cl cmd tail_asm lc = (Some asm_app_tail, lc') ->
  exists asm,
    asm_app_tail = asm ++ tail_asm /\
    compile_cmd fd d vro vd bl cl cmd [] lc = (Some asm, lc').
Proof. Admitted.

Lemma compile_expr_eq_cons_tail_asm fd d vro vd lc lc' cmd tail_asm asm_app_tail :
  compile_expr fd d vro vd cmd tail_asm lc = (Some asm_app_tail, lc') ->
  exists asm,
    asm_app_tail = asm ++ tail_asm /\
    compile_expr fd d vro vd cmd [] lc = (Some asm, lc').
Proof. Admitted.

Definition cmd_compiles_to fd vro vd (depth : nat) (cmd : cmd) (asm : asm) : Prop :=
  exists  cl bl label_counter label_counter',
    compile_cmd fd depth vro vd bl cl cmd [] label_counter = (Some asm, label_counter').

Definition expr_compiles_to fd vro vd (depth : nat) (expr : annotated_expr) (asm : asm) : Prop :=
  exists  label_counter label_counter',
    compile_expr fd depth vro vd expr [] label_counter = (Some asm, label_counter').

(* Definition subprogram
    (prog : prog) (func_id : func_id) (first_instr_index last_instr_index : nat) (asm : asm) :=
  exists func_asm, FuncIdMap.find func_id prog = Some func_asm /\
                   sublist asm first_instr_index last_instr_index func_asm. *)

Definition backward_simulates
    (nb_steps : nat) (funcs : list (func_id * func)) (prog : prog) (func_id : func_id)
    (cmd : cmd) (asm : asm) (first_instr_index last_instr_index : nat) : Prop :=
  forall c_var_ptrs c_var_ptrs' c_state c_state' asm_state regs rbp,
    star_count (continued_step funcs) nb_steps (c_var_ptrs, c_state, ContinuedCmd cmd KStop)
                                               (c_var_ptrs', c_state', ContinuedCmd Skip KStop) ->
    r_rbp regs = PtrValue (StackPtr rbp) ->
    states_equivalent rbp func_id c_var_ptrs c_state asm_state ->
    exists regs' asm_state' rbp',
      r_rbp regs' = PtrValue (StackPtr rbp') /\
      states_equivalent rbp' func_id c_var_ptrs' c_state' asm_state' /\
      star (instr_step prog) (asm_state, (func_id, first_instr_index), regs)
                             (asm_state', (func_id, last_instr_index), regs').

Definition backward_simulates_expr
    (nb_steps : nat) (funcs : list (func_id * func)) (prog : prog) (func_id : func_id)
    (expr : annotated_expr) (asm : asm) (first_instr_index last_instr_index : nat) : Prop :=
  forall c_var_ptrs c_var_ptrs' c_state c_state' asm_state regs rbp val ty,
    star_count (continued_step funcs) nb_steps
                  (c_var_ptrs, c_state, ContinuedExpr expr (KExpr KStop))
                  (c_var_ptrs', c_state', ContinuedExpr (Const val <: ty) (KExpr KStop)) ->
    r_rbp regs = PtrValue (StackPtr rbp) ->
    states_equivalent rbp func_id c_var_ptrs c_state asm_state ->
    exists regs' asm_state' rbp',
      r_rbp regs' = PtrValue (StackPtr rbp') /\
      r_rax regs' = val /\
      states_equivalent rbp' func_id c_var_ptrs' c_state' asm_state' /\
      star (instr_step prog) (asm_state, (func_id, first_instr_index), regs)
                             (asm_state', (func_id, last_instr_index), regs').

Ltac destruct_compile_cmd cmd :=
  let a := fresh "asm" in
  let lc := fresh "label_counter" in
  let H := fresh "Hcompile" in
  destruct (compile_cmd _ _ _ _ _ _ cmd _ _) as [[a | ] lc] eqn:H; try discriminate.

Ltac destruct_compile_expr expr :=
  let a := fresh "asm" in
  let lc := fresh "label_counter" in
  let H := fresh "Hcompile" in
  destruct (compile_expr _ _ _ _ expr _ _) as [[a | ] lc] eqn:H; try discriminate.

Ltac elim_tail_asm cmd :=
  match goal with
  | [ H : compile_cmd _ _ _ _ _ _ cmd _ _ = (Some _, _) |- _ ] =>
      let asm := fresh "asm" in
      let Hasm_app := fresh "Hasm_app" in
      let Hcompile := fresh "Hcompile" in
      apply compile_cmd_eq_cons_tail_asm in H;
      destruct H as [asm [Hasm_app Hcompile]];
      clear H; subst
  end.

Ltac elim_tail_asm_expr expr :=
  match goal with
  | [ H : compile_expr _ _ _ _ expr _ _ = (Some _, _) |- _ ] =>
      let asm := fresh "asm" in
      let Hasm_app := fresh "Hasm_app" in
      let Hcompile_expr := fresh "Hcompile" in
      apply compile_expr_eq_cons_tail_asm in H;
      destruct H as [asm [Hasm_app Hcompile_expr]];
      clear H; subst
  end.

Ltac separate_first cmd cont cmd' cont' :=
  match goal with
  | [ Hstar_continued_step : star_count (continued_step _) _
                                (_, _, _ cmd cont)
                                (_, _, _ cmd' cont') |- _] =>
    let Hstar_continued_step' := fresh "Hstar_continued_step" in
    let Hstar_continued_step'' := fresh "Hstar_continued_step" in
    let Hcontinued_step := fresh "continued_step" in
    let Hineq := fresh "Hineq" in
    let nb_steps := fresh "nb_steps" in
    let nb_steps' := fresh "nb_steps" in
    let x := fresh "x" in
    let y := fresh "y" in
    inversion Hstar_continued_step
      as [nb_steps x | nb_steps' x y z Hcontinued_step Hstar_continued_step']; subst;
    inversion Hcontinued_step; subst;
    destruct (star_from_middle_of_deterministic_of_final_count
                  (continued_step_deterministic _) (Skip_KStop_final _ _ _)
                  (StarCountCons Hcontinued_step StarCountRefl) Hstar_continued_step)
        as [Hineq Hstar_continued_step'']
  end.

Ltac separate_last expr :=
  match goal with
  | [ Hstar_continued_step : star_count (continued_step _) _
                                          (_, _, ContinuedExpr expr (KExpr KStop))
                                          (_, _, ContinuedCmd Skip KStop) |- _ ] =>
  let val := fresh "val" in let ty := fresh "ty" in
  let Hstar_continued_step' := fresh "Hstar_continued_step" in
  destruct (continued_step_KExpr_of_continued_step_KStop _ _ _ _ _ _ _ Hstar_continued_step)
    as [val [ty Hstar_continued_step']]
  end.

Ltac from_middle cmd cont cmd' cont' :=
  match goal with
  | [ Hstar_continued_step : star_count (continued_step _) _ _ (_, _, _ cmd cont),
      Hstar_continued_step' : star_count (continued_step _) _ _ (_, _, _ cmd' cont') |- _ ] =>
    let Hstar_continued_step'' := fresh "Hstar_continued_step" in
    let Hstar_continued_step''' := fresh "Hstar_continued_step" in
    let Hineq := fresh "Hineq" in
    destruct (star_from_middle_of_deterministic_of_final_count
                (continued_step_deterministic _) (Skip_KStop_final _ _ _)
                Hstar_continued_step Hstar_continued_step')
      as [Hineq Hstar_continued_step''']
  end.

Ltac fastest_same_cont_skip_full cmd cont :=
  match goal with
  | [ Hstar_continued_step : star_count (continued_step _) _
                                (_, _, ContinuedCmd cmd cont)
                                (_, _, ContinuedCmd Skip KStop) |- _ ] =>
    let Hstar_continued_step' := fresh "Hstar_continued_step" in
    let Hstar_continued_step'' := fresh "Hstar_continued_step" in
    let nb_steps := fresh "nb_steps" in
    let var_ptrs := fresh "var_ptrs" in
    let Hineq := fresh "Hineq" in
    let H := fresh "H" in
    assert (H := Hstar_continued_step);
    apply continued_step_KStop_and_cont_of_continued_step_Skip_KStop in H;
    destruct H as [nb_steps [var_ptrs [state [Hineq [Hstar_continued_step' Hstarcontinued_step'']]]]];
    from_middle Skip cont Skip KStop
  end.

Ltac fastest_same_cont_skip_full_expr expr cont :=
  match goal with
  | [ Hstar_continued_step : star_count (continued_step _) _
                                (_, _, ContinuedExpr expr cont)
                                (_, _, ContinuedCmd Skip KStop) |- _ ] =>
    let Hstar_continued_step' := fresh "Hstar_continued_step" in
    let Hstar_continued_step'' := fresh "Hstar_continued_step" in
    let nb_steps := fresh "nb_steps" in
    let var_ptrs := fresh "var_ptrs" in
    let Hineq := fresh "Hineq" in
    let val := fresh "val" in
    let ty := fresh "ty" in
    let H := fresh "H" in
    assert (H := Hstar_continued_step);
    apply continued_step_KStop_and_cont_of_continued_step_Expr_const_KStop in H;
    destruct H as [nb_steps [var_ptrs [state [val [ty [Hineq [Hstar_continued_step' Hstarcontinued_step'']]]]]]];
    from_middle (Const val <: ty) cont Skip KStop
  end.

Ltac simulate_cmd IH nb_steps cmd asm_state Hrbp Hstates_equivalent Hstar_continued_step :=
  let Hsimulation := fresh "Hsimulation" in
  let regs' := fresh "regs" in
  let asm_state' := fresh "asm_state" in
  let rbp' := fresh "rbp" in
  let Hrbp' := fresh "Hrbp" in
  let Hstates_equivalent' := fresh "Hstates_equivalent" in
  let Hstar_instr_step' := fresh "Hstar_instr_step" in
  eassert (Hsimulation : backward_simulates nb_steps _ _ _ cmd _ _ _);
  try ( eapply IH; try (eexists; repeat eexists; eassumption); try eassumption; try lia;
        (eapply sublist_of_app_sublist_left; eassumption) ||
        (eapply sublist_of_app_sublist_right; eassumption) );
  destruct (Hsimulation _ _ _ _ asm_state _ _ Hstar_continued_step Hrbp Hstates_equivalent)
    as [regs' [asm_state' [rbp' [Hrbp' [Hstates_equivalent' Hstar_instr_step']]]]].

Ltac simulate_cmd' IH nb_steps cmd asm_state Hrbp Hstates_equivalent Hstar_continued_step :=
  let Hsimulation := fresh "Hsimulation" in
  let regs' := fresh "regs" in
  let asm_state' := fresh "asm_state" in
  let rbp' := fresh "rbp" in
  let Hrbp' := fresh "Hrbp" in
  let Hstates_equivalent' := fresh "Hstates_equivalent" in
  let Hstar_instr_step' := fresh "Hstar_instr_step" in
  eassert (Hsimulation : backward_simulates nb_steps _ _ _ cmd _ _ _) (* ;
  try ( eapply IH; try (eexists; repeat eexists; eassumption); try eassumption; try lia;
        (eapply sublist_of_app_sublist_left; eassumption) ||
        (eapply sublist_of_app_sublist_right; eassumption) );
  destruct (Hsimulation _ _ _ _ asm_state _ _ Hstar_continued_step Hrbp Hstates_equivalent)
    as [regs' [asm_state' [rbp' [Hrbp' [Hstates_equivalent' Hstar_instr_step']]]]]. *).

Ltac simulate_expr IH nb_steps expr asm_state Hrbp Hstates_equivalent Hstar_continued_step :=
  let Hsimulation := fresh "Hsimulation" in
  let regs' := fresh "regs" in
  let asm_state' := fresh "asm_state" in
  let rbp' := fresh "rbp" in
  let Hrbp' := fresh "Hrbp" in
  let Hrax' := fresh "Hrax" in
  let Hstates_equivalent' := fresh "Hstates_equivalent" in
  let Hstar_instr_step' := fresh "Hstar_instr_step" in
  eassert (Hsimulation : backward_simulates_expr nb_steps _ _ _ expr _ _ _);
  try ( eapply IH; try (eexists; repeat eexists; eassumption); try eassumption; try lia;
        (eapply sublist_of_app_sublist_left; eassumption) ||
        (eapply sublist_of_app_sublist_right; eassumption) );
  destruct (Hsimulation _ _ _ _ asm_state _ _ _ _  Hstar_continued_step Hrbp Hstates_equivalent)
    as [regs' [asm_state' [rbp' [Hrbp' [Hrax' [Hstates_equivalent' Hstar_instr_step']]]]]].

Theorem backward_simulation_aux nb_steps :
  ( forall funcs prog func_id func func_asm fd vro vd cmd cmd_asm first_instr_index last_instr_index,
      compile_file funcs = Some prog ->
      In (func_id, func) funcs ->
      FuncIdMap.find func_id prog = Some func_asm ->
      cmd_compiles_to fd vro vd (depth func) cmd cmd_asm ->
      sublist cmd_asm first_instr_index last_instr_index func_asm ->
      backward_simulates nb_steps funcs prog func_id cmd
                         cmd_asm first_instr_index last_instr_index ) /\
  ( forall funcs prog func_id func func_asm fd vro vd expr expr_asm first_instr_index last_instr_index,
      compile_file funcs = Some prog ->
      In (func_id, func) funcs ->
      FuncIdMap.find func_id prog = Some func_asm ->
      expr_compiles_to fd vro vd (depth func) expr expr_asm ->
      backward_simulates_expr nb_steps funcs prog func_id expr
                              expr_asm first_instr_index last_instr_index ).
Proof.
  induction (lt_wf nb_steps) as [n _ IH].

  assert (IHCmd := fun nb_steps Hnb_steps => proj1 (IH nb_steps Hnb_steps)).
  assert (IHExpr := fun nb_steps Hnb_steps => proj2 (IH nb_steps Hnb_steps)).
  clear IH.

  split.

  - (* Case : show that commands are compiled correctly *)
    intros funcs0 prog func_id func func_asm fd vro vd cmd cmd_asm first_instr_index last_instr_index
          Hcompile_file Hfunc_In Hfunc_asm [bl [cl [lc [lc' Hcompile]]]] Hsublist
          c_var_ptrs c_var_ptrs' c_state c_state' asm_state regs rbp
          Hstar_continued_step Hrbp Hstates_equivalent.

    destruct cmd as [ | cmd1 cmd2 | expr | cond_expr then_cmd else_cmd | | | | | ];
    simpl in Hcompile.

    + (* Case : cmd = Skip *)
      injection Hcompile as Hcompile. subst.
      inv Hstar_continued_step.

      * (* Zero C small steps. *)
        (* Since there are zero c steps, we can show that the c states before and after are equal
            and that the o compiled command is Skip.
          Then, by executing no instructions the assembly program transitions to the same state
            in zero steps. *)
        exists regs. exists asm_state. exists rbp.
        repeat split; try assumption.
        apply nil_sublist in Hsublist. subst.
        apply StarRefl.

      * (* At least one C small step. *)
        (* This is impossible: no step can be made from [ContinuedInstr Skip KStop] *)
        inv H.

    + (* Case: cmd = Seq cmd1 cmd2 *)
      destruct_compile_cmd cmd2. destruct_compile_cmd cmd1.
      injection Hcompile. intros. subst.
      elim_tail_asm cmd1.

      separate_first (Seq cmd1 cmd2) KStop Skip KStop.
      fastest_same_cont_skip_full cmd1 (KSeq cmd2 KStop).
      separate_first Skip (KSeq cmd2 KStop) Skip KStop.

      simulate_cmd IHCmd nb_steps cmd1 asm_state Hrbp Hstates_equivalent Hstar_continued_step2.
      simulate_cmd IHCmd (S nb_steps0-1-nb_steps-1) cmd2 asm_state0 Hrbp0 Hstates_equivalent0
                     Hstar_continued_step5.

      exists regs1. exists asm_state1. exists rbp1.
      repeat split; try assumption.
      eapply star_trans; eassumption.

    + (* Case : cmd = Expr expr *)
      separate_first (Expr expr) KStop Skip KStop.
      separate_last expr.

      simulate_expr IHExpr (S nb_steps0-1-1) expr asm_state Hrbp Hstates_equivalent Hstar_continued_step2.
      exists regs0. exists asm_state0. exists rbp0.
      repeat split; eassumption.

    + (* Case : cmd = If cond_expr then_cmd else_cmd *)
      destruct_compile_cmd else_cmd. destruct_compile_cmd then_cmd.
      destruct_compile_expr cond_expr.
      elim_tail_asm_expr cond_expr. elim_tail_asm then_cmd. elim_tail_asm else_cmd.
      injection Hcompile. intros. subst.

      separate_first (If cond_expr then_cmd else_cmd) KStop Skip KStop.
      fastest_same_cont_skip_full_expr cond_expr (KIf then_cmd else_cmd KStop).
      separate_first (Const val <: ty) (KIf then_cmd else_cmd KStop) Skip KStop;
      try (inv H6; discriminate);
      try (inv continued_step0; inv H2; try discriminate; inv H10; discriminate).

      eassert (Hsublist1 : sublist asm1 (2 + first_instr_index + length asm2)
                                   (2 + first_instr_index + length asm2 + length asm1) func_asm).
      { admit. (* This is just a tideous manipulation on lists *) }

      simulate_expr IHExpr nb_steps cond_expr asm_state Hrbp Hstates_equivalent Hstar_continued_step2.

      destruct bool.
      * (* The condition is true, the then branch is executed *)
Abort.

(* Theorem backward_simulation_aux nb_steps :
  forall funcs prog func_id func func_asm fd vro vd cmd cmd_asm first_instr_index last_instr_index,
    compile_file funcs = Some prog ->
    In (func_id, func) funcs ->
    FuncIdMap.find func_id prog = Some func_asm ->
    cmd_compiles_to fd vro vd (depth func) cmd cmd_asm ->
    sublist cmd_asm first_instr_index last_instr_index func_asm ->
    backward_simulates nb_steps funcs prog func_id cmd cmd_asm first_instr_index last_instr_index.
Proof.
  induction (lt_wf nb_steps) as [n _ IH].

  intros funcs0 prog func_id func func_asm fd vro vd cmd cmd_asm first_instr_index last_instr_index
         Hcompile_file Hfunc_In Hfunc_asm [bl [cl [lc [lc' Hcompile]]]] Hsublist
         c_var_ptrs c_var_ptrs' c_state c_state' asm_state regs rbp
         Hstar_continued_step Hrbp Hstates_equivalent.

  destruct cmd;
  simpl in Hcompile.

  - (* Case : cmd = Skip *)
    injection Hcompile as Hcompile. subst.

    inv Hstar_continued_step.

  + (* Zero C small steps. *)
    (* Since there are zero c steps, we can show that the c states before and after are equal
         and that the o compiled command is Skip.
       Then, by executing no instructions the assembly program transitions to the same state
         in zero steps. *)
    exists regs. exists asm_state. exists rbp.
    repeat split; try assumption.
    apply nil_sublist in Hsublist. subst.
    apply StarRefl.

  + (* At least one C small step. *)
    (* This is impossible: no step can be made from [ContinuedInstr Skip KStop] *)
    inv H.

  - (* Case: cmd = Seq cmd1 cmd2 *)
    destruct_compile_cmd cmd2. destruct_compile_cmd cmd1.
    injection Hcompile. intros. subst.
    elim_tail_asm cmd1.

    inversion Hstar_continued_step; subst. (* necessarily at least one step *)
    inversion H. subst.
    destruct (star_from_middle_of_deterministic_of_final_count
                  (continued_step_deterministic _) (Skip_KStop_final _ _ _)
                  (StarCountCons H StarCountRefl) Hstar_continued_step)
        as [Hineq Hstar_continued_step'].

    apply continued_step_same_continuation_of_continued_step_SKip_KStop in Hstar_continued_step'.
    destruct Hstar_continued_step' as [n' [var_ptrs'' [state'' [Hineq' Hstar_continued_step']]]].
    apply continued_step_KStop_of_continued_step_Skip_same_cont in Hstar_continued_step'.
    destruct Hstar_continued_step' as [n'' [var_ptrs''' [state''' [Hineq'' Hstar_continued_step'']]]].

    (* we state and show by induction hypothesis that the compiled cmd1 is emulated correctly *)
    assert (Hemulation_cmd1 : exists regs' asm_state' rbp',
      r_rbp regs' = PtrValue (StackPtr rbp') /\
      states_equivalent rbp' func_id var_ptrs''' state''' asm_state' /\
      star (instr_step prog)
        (asm_state, (func_id, first_instr_index), regs)
        (asm_state', (func_id, first_instr_index + length asm0), regs')).
    { eapply IH with (cmd := cmd1) (c_var_ptrs' := var_ptrs''') (y := n''); try eassumption.
      + lia.
      + econstructor; repeat eexists. eassumption.
      + eapply sublist_of_app_sublist_left; eassumption. }

    destruct Hemulation_cmd1 as
      [regs1 [asm_state1 [rbp1 [Hrbp1 [Hstates_equivalent1 Hstar_instr_step1]]]]].

    assert (Hstar_continued_step''' := H0).
    apply continued_step_same_continuation_of_continued_step_SKip_KStop in H0.
    destruct H0 as [nb_steps0 [var_ptrs' [state0 [Hineq0 Hstar_continued_step0]]]].
    assert (Hcontinued_step0 : star_count (continued_step funcs0) (S nb_steps0)
                                (c_var_ptrs, c_state, ContinuedCmd cmd1 (KSeq cmd2 KStop))
                                (var_ptrs', c_state, ContinuedCmd cmd2 (KStop))).
   {  assert (Harith : S nb_steps0 = nb_steps0 + 1). { lia. }
      rewrite Harith.
      eapply star_count_trans.
     + eassumption.
     + repeat econstructor. }

  assert (h := star_from_middle_of_deterministic_of_final_count
    (continued_step_deterministic _) (Skip_KStop_final _ _ _) .......).

Theorem backward_simulation_aux nb_steps :
  forall fd vro vd funcs prog func_id func func_asm cmd cmd_asm first_instr_index last_instr_index
         c_state c_state' c_var_ptrs c_var_ptrs' asm_state regs rbp,
    compile_file funcs = Some prog ->
    In (func_id, func) funcs ->
    compile_func fd (depth func) vro vd (f_body func) = Some func_asm ->
    cmd_compiles_to fd vro vd (depth func) cmd cmd_asm ->
    sublist cmd_asm first_instr_index last_instr_index func_asm ->
    r_rbp regs = PtrValue (StackPtr rbp) ->
    states_equivalent rbp func_id c_var_ptrs c_state asm_state ->
    star_count (continued_step funcs) nb_steps (c_var_ptrs, c_state, ContinuedCmd cmd KStop)
                                               (c_var_ptrs', c_state', ContinuedCmd Skip KStop) ->
    exists regs' asm_state' rbp',
      r_rbp regs' = PtrValue (StackPtr rbp') /\
      states_equivalent rbp' func_id c_var_ptrs' c_state' asm_state' /\
      star (instr_step prog) (asm_state, (func_id, first_instr_index), regs)
                             (asm_state', (func_id, last_instr_index), regs').

Proof.

  induction (lt_wf nb_steps) as [n _ IH].

  intros fd vro vd funcs0 prog func_id func func_asm cmd cmd_asm first_instr_index last_instr_index
         c_state c_state' c_var_ptrs c_var_ptrs' asm_state regs rbp
         Hcompile_file Hcompile_func Hfunc_In Hcompile Hsublist Hrbp Hstates_equivalent
         Hstar_continued_step.

  destruct cmd;

  (* simplify Hcompile *)
  inv Hcompile; inv H; inv H0; inv H; simpl in H0; rename H0 into Hcompile;
  rename x into break_lbl; rename x0 into continue_lbl;
  rename x1 into label_counter; rename x2 into label_counter'.

  - (* Case : cmd = Skip *)

    injection Hcompile as Hcompile. subst.

    inv Hstar_continued_step.

    + (* Zero C small steps. *)
      (* Since there are zero c steps, we can show that the c states before and after are equal
           and that the o compiled command is Skip.
         Then, by executing no instructions the assembly program transitions to the same state
           in zero steps. *)
      exists regs. exists asm_state. exists rbp.
      repeat split; try assumption.
      apply nil_sublist in Hsublist. subst.
      apply StarRefl.

    + (* At least one C small step. *)
      (* This is impossible: no step can be made from [ContinuedInstr Skip KStop] *)
      inv H.

  - (* Case: cmd = Seq cmd1 cmd2 *)

    destruct_compile_cmd cmd2. destruct_compile_cmd cmd1.
    injection Hcompile. intros. subst.
    elim_tail_asm cmd1.

    inversion Hstar_continued_step; subst. (* necessarily at least one step *)
    inversion H. subst.
    destruct (star_from_middle_of_deterministic_of_final_count
                  (continued_step_deterministic _) (Skip_KStop_final _ _ _)
                  (StarCountCons H StarCountRefl) Hstar_continued_step)
        as [Hineq Hstar_continued_step'].

    apply continued_step_same_continuation_of_continued_step_SKip_KStop in Hstar_continued_step'.
    destruct Hstar_continued_step' as [n' [var_ptrs'' [state'' [Hineq' Hstar_continued_step']]]].
    apply continued_step_KStop_of_continued_step_Skip_same_cont in Hstar_continued_step'.
    destruct Hstar_continued_step' as [n'' [var_ptrs''' [state''' [Hineq'' Hstar_continued_step'']]]].

    (* we state and show by induction hypothesis that the compiled cmd1 is emulated correctly *)
    assert (Hemulation_cmd1 : exists regs' asm_state' rbp',
      r_rbp regs' = PtrValue (StackPtr rbp') /\
      states_equivalent rbp' func_id var_ptrs''' state''' asm_state' /\
      star (instr_step prog)
        (asm_state, (func_id, first_instr_index), regs)
        (asm_state', (func_id, first_instr_index + length asm0), regs')).
    { eapply IH with (cmd := cmd1) (c_var_ptrs' := var_ptrs''') (y := n''); try eassumption.
      + lia.
      + econstructor; repeat eexists. eassumption.
      + eapply sublist_of_app_sublist_left; eassumption. }

    destruct Hemulation_cmd1 as
      [regs1 [asm_state1 [rbp1 [Hrbp1 [Hstates_equivalent1 Hstar_instr_step1]]]]].

Qed.
    *)

End CodegenLemmas.


Require Import Framework File FileDiskLayer FileDiskNoninterference FileDiskRefinement.
Require Import FunctionalExtensionality Lia Language SameRetType.
Require Import TSCommon InodeTS TSAuthThenExec.

Opaque Inode.get_inode DiskAllocator.alloc Inode.extend.
Lemma TS_extend_inner:
forall o fm1 fm2 s1 s2 inum v v' ret1 u u' ex,
same_for_user_except u' ex fm1 fm2 ->
files_inner_rep fm1 (fst (snd s1)) ->
files_inner_rep fm2 (fst (snd s2)) ->
exec (TransactionalDiskLayer.TDLang FSParameters.data_length) u o s1 (extend_inner v inum) ret1 ->
exists ret2,
exec (TransactionalDiskLayer.TDLang FSParameters.data_length) u o s2 (extend_inner v' inum) ret2 /\
(extract_ret ret1 = None <-> extract_ret ret2 = None).
Proof.
Transparent extend_inner.
unfold extend_inner; intros.
invert_step.
{
  eapply_fresh TS_alloc in H2; eauto.
  cleanup.
  destruct x2; simpl in *; try solve [intuition congruence].

  eapply_fresh DiskAllocator.alloc_finished_oracle_eq in H2; eauto.
  cleanup; destruct o; try solve [intuition congruence].
  unfold refines, files_rep, files_inner_rep in *; cleanup.
  eapply DiskAllocator.alloc_finished in H2; eauto.
  cleanup; split_ors; cleanup.
  eapply_fresh DiskAllocator.alloc_finished in H4; eauto.
  cleanup; split_ors; cleanup.

  eapply_fresh TS_extend in H3; eauto.
  cleanup.
  destruct x8; simpl in *; try solve [intuition congruence].
  eapply Inode.extend_finished_oracle_eq in H3; eauto; cleanup.

  eexists; split.
  econstructor.
  simpl; eapply H4.
  simpl; eauto.
  simpl; intuition congruence.

  {
    repeat cleanup_pairs; simpl in *.
    unfold files_inner_rep; eexists; intuition eauto.

    unfold Inode.inode_rep in *; cleanup.
    eexists; split.
    eapply Inode.InodeAllocator.block_allocator_rep_inbounds_eq with (s1:= t3); eauto.
    intros; repeat solve_bounds.
    eauto.
    eexists; intuition eauto.
    {
      unfold file_map_rep in *; cleanup.
      intuition eauto.
      eapply H19 in H20; eauto.
      unfold file_rep in *; cleanup.
      intuition eauto.
      eapply H23 in H24; cleanup.
      eexists; intuition eauto.
      rewrite Mem.upd_ne; eauto.
      intros Hnot; subst; congruence.
    }
  }
  {
    repeat cleanup_pairs; simpl in *.
    unfold files_inner_rep; eexists; intuition eauto.

    unfold Inode.inode_rep in *; cleanup.
    eexists; split.
    eapply Inode.InodeAllocator.block_allocator_rep_inbounds_eq; eauto.
    intros; repeat solve_bounds.
    eauto.
    eexists; intuition eauto.
    {
      unfold file_map_rep in *; cleanup.
      intuition eauto.
      eapply H17 in H20; eauto.
      unfold file_rep in *; cleanup.
      intuition eauto.
      eapply H23 in H24; cleanup.
      eexists; intuition eauto.
      rewrite Mem.upd_ne; eauto.
      intros Hnot; subst; congruence.
    }
  }
}
{
  eapply_fresh TS_alloc in H2; eauto.
  cleanup.
  destruct x0; simpl in *; try solve [intuition congruence].

  eapply_fresh DiskAllocator.alloc_finished_oracle_eq in H2; eauto.
  cleanup; destruct o; try solve [intuition congruence].

  eexists; split.
  econstructor.
  simpl; eapply H3.
  simpl; eauto.
  repeat econstructor.
  simpl; intuition congruence.
}
{
  repeat invert_step_crash.
  {
    eapply_fresh TS_alloc in H2; eauto.
    cleanup.
    destruct x; simpl in *; try solve [intuition congruence].

    exists (Crashed s0); split.
    repeat exec_step.
    eapply ExecBindCrash; eauto.
    simpl; intuition eauto.
  }
  {
    eapply_fresh TS_alloc in H3; eauto.
    logic_clean.
    destruct x3; simpl in *; try solve [intuition congruence].

    eapply_fresh DiskAllocator.alloc_finished_oracle_eq in H3; eauto.
    logic_clean.
    unfold refines, files_rep, files_inner_rep in *; logic_clean.
    eapply DiskAllocator.alloc_finished in H3; eauto.
    eapply_fresh DiskAllocator.alloc_finished in H2; eauto.
    cleanup; repeat split_ors; cleanup; try solve [intuition congruence].
    {
      eapply_fresh TS_extend in H4; eauto.
      cleanup.
      destruct x8; simpl in *; try solve [intuition congruence].
      exists (Crashed s3); split.
      econstructor; simpl; eauto.
      simpl; eauto.
      simpl; intuition eauto.
      {
    repeat cleanup_pairs; simpl in *.
    unfold files_inner_rep; eexists; intuition eauto.

    unfold Inode.inode_rep in *; cleanup.
    eexists; split.
    eapply Inode.InodeAllocator.block_allocator_rep_inbounds_eq with (s1:= t3); eauto.
    intros; repeat solve_bounds.
    eauto.
    eexists; intuition eauto.
    {
      unfold file_map_rep in *; cleanup.
      intuition eauto.
      eapply H19 in H20; eauto.
      unfold file_rep in *; cleanup.
      intuition eauto.
      eapply H23 in H24; cleanup.
      eexists; intuition eauto.
      rewrite Mem.upd_ne; eauto.
      intros Hnot; subst; congruence.
    }
  }
  {
    repeat cleanup_pairs; simpl in *.
    unfold files_inner_rep; eexists; intuition eauto.

    unfold Inode.inode_rep in *; cleanup.
    eexists; split.
    eapply Inode.InodeAllocator.block_allocator_rep_inbounds_eq; eauto.
    intros; repeat solve_bounds.
    eauto.
    eexists; intuition eauto.
    {
      unfold file_map_rep in *; cleanup.
      intuition eauto.
      eapply H10 in H20; eauto.
      unfold file_rep in *; cleanup.
      intuition eauto.
      eapply H23 in H24; cleanup.
      eexists; intuition eauto.
      rewrite Mem.upd_ne; eauto.
      intros Hnot; subst; congruence.
    }
  }
  }
  {
      invert_step; eexists; split.
      repeat exec_step.
      simpl; intuition congruence.
  }
}
}
Unshelve.
all: eauto.
Qed.
Opaque extend_inner.

Theorem Termination_Sensitive_extend:
  forall u u' m inum v1 ex,
    Termination_Sensitive
      u (extend inum v1) (extend inum v1) recover
      AD_valid_state (AD_related_states u' ex)
      (authenticated_disk_reboot_list m).
Proof.
  Opaque extend_inner.
  unfold Termination_Sensitive, AD_valid_state,
  AD_related_states, FD_valid_state, FD_related_states,
  refines_valid, refines_related,
  authenticated_disk_reboot_list,
  extend;
  intros; cleanup; simpl in *.
  destruct m; simpl in *.
  {(**write finished **)
   invert_exec.
   eapply TS_auth_then_exec in H11; eauto.
   {
     cleanup.
     destruct x1; simpl in *; try solve [intuition congruence].
     eexists; econstructor_recovery.
     eauto.
   }
   {
     intros.
     eapply_fresh TS_extend_inner in H7; eauto.
     cleanup.
     destruct ret1, x1; simpl in * ; try solve [intuition congruence].
     {
      eapply SameRetType.extend_inner_finished_oracle_eq in H7; eauto.
      cleanup.
      eexists.
      intuition eauto; cleanup; eauto.
     }
     {
      eexists.
      intuition eauto; cleanup; eauto.
     }
   }
  }
  {
    invert_exec.
    eapply_fresh TS_auth_then_exec in H14; eauto.
   {
     cleanup.
     destruct x1; simpl in *; try solve [intuition congruence].
     eapply_fresh FileSpecs.extend_crashed in H14; eauto.
    eapply_fresh FileSpecs.extend_crashed in H1; eauto.
    repeat split_ors; cleanup.
    {
      match goal with
        [H: refines ?s1 ?x,
        H0: refines ?s2 ?x0,
        H1: same_for_user_except _ _ ?x ?x0,
        A : recovery_exec' _ _ _ _ _ _ _ |- _] =>
          eapply Termination_Sensitive_recover in A;
          try instantiate (1:= (fst s, (snd (snd s), snd (snd s)))) in A;
          unfold AD_valid_state, refines_valid, FD_valid_state;
          intros; eauto
     end.
     edestruct H15.
     2: eexists; econstructor_recovery; [|eauto]; eauto.
     {
       instantiate (1:= ex).
       unfold AD_related_states, refines_related,
       FD_related_states in *; simpl;
       unfold refines, files_rep, files_crash_rep in *; simpl.
       do 2 eexists; intuition eauto.
     }
   }
   {
     exfalso; eapply extend_crashed_exfalso; eauto.
   }
   {
     exfalso; eapply extend_crashed_exfalso.
     eapply same_for_user_except_symmetry. eauto.
     all: eauto.
   }
   {
      match goal with
        [H: refines ?s1 ?x,
        H0: refines ?s2 ?x0,
        H1: same_for_user_except _ _ ?x ?x0,
        A : recovery_exec' _ _ _ _ _ _ _ |- _] =>
          eapply Termination_Sensitive_recover in A;
          try instantiate (1:= (fst s, (snd (snd s), snd (snd s)))) in A;
          unfold AD_valid_state, refines_valid, FD_valid_state;
          intros; eauto
     end.
     edestruct H15.
     2: eexists; econstructor_recovery; [|eauto]; eauto.
     {
       instantiate (1:= ex).
       unfold AD_related_states, refines_related,
       FD_related_states in *; simpl;
       unfold refines, files_rep, files_crash_rep in *; simpl.
       do 2 eexists; intuition eauto.
       {
         unfold same_for_user_except in *; cleanup.
         split; intros.
         unfold addrs_match_exactly in *; intros.
         destruct (addr_dec a1 inum);
         [repeat rewrite Mem.upd_eq; eauto; intuition congruence
         |repeat rewrite Mem.upd_ne; eauto; intuition congruence].
         split; intros.
         {
          destruct (addr_dec inum0 inum);
          [rewrite Mem.upd_eq in H5, H16; eauto; cleanup
         |rewrite Mem.upd_ne in H5, H16; eauto; cleanup].
         unfold extend_file in *; simpl in *.
         eapply e in H19; eauto.
         subst; eauto.
         }
         {
          destruct (addr_dec inum0 inum);
          [rewrite Mem.upd_eq in H5, H4; eauto; cleanup
         |rewrite Mem.upd_ne in H5, H4; eauto; cleanup].
         unfold extend_file in *; simpl in *.
         eapply a0 in H7; eauto.
         cleanup; intuition eauto.
         repeat rewrite app_length; lia.
         }
       }
     }
   }
  }
  {
     intros.
     eapply_fresh TS_extend_inner in H7; eauto.
     cleanup.
     destruct ret1, x1; simpl in * ; try solve [intuition congruence].
     {
      eapply SameRetType.extend_inner_finished_oracle_eq in H7; eauto.
      cleanup.
      eexists.
      intuition eauto; cleanup; eauto.
     }
     {
      eexists.
      intuition eauto; cleanup; eauto.
     }
  }
}
Unshelve.
all: eauto.
Qed.

Theorem Termination_Sensitive_extend_input:
  forall u u' m inum v1 v2,
    Termination_Sensitive
      u (extend inum v1) (extend inum v2) recover
      AD_valid_state (AD_related_states u' (Some inum))
      (authenticated_disk_reboot_list m).
Proof.
  Opaque extend_inner.
  unfold Termination_Sensitive, AD_valid_state,
  AD_related_states, FD_valid_state, FD_related_states,
  refines_valid, refines_related,
  authenticated_disk_reboot_list,
  extend;
  intros; cleanup; simpl in *.
  destruct m; simpl in *.
  {(**write finished **)
   invert_exec.
   eapply TS_auth_then_exec in H11; eauto.
   {
     cleanup.
     destruct x1; simpl in *; try solve [intuition congruence].
     eexists; econstructor_recovery.
     eauto.
   }
   {
     intros.
     eapply_fresh TS_extend_inner in H7; eauto.
     cleanup.
     destruct ret1, x1; simpl in * ; try solve [intuition congruence].
     {
      eapply SameRetType.extend_inner_finished_oracle_eq in H7; eauto.
      cleanup.
      eexists.
      intuition eauto; cleanup; eauto.
     }
     {
      eexists.
      intuition eauto; cleanup; eauto.
     }
   }
  }
  {
    invert_exec.
    eapply_fresh TS_auth_then_exec in H14; eauto.
   {
     cleanup.
     destruct x1; simpl in *; try solve [intuition congruence].
     eapply_fresh FileSpecs.extend_crashed in H14; eauto.
    eapply_fresh FileSpecs.extend_crashed in H1; eauto.
    repeat split_ors; cleanup.
    {
      match goal with
        [H: refines ?s1 ?x,
        H0: refines ?s2 ?x0,
        H1: same_for_user_except _ _ ?x ?x0,
        A : recovery_exec' _ _ _ _ _ _ _ |- _] =>
          eapply Termination_Sensitive_recover in A;
          try instantiate (1:= (fst s, (snd (snd s), snd (snd s)))) in A;
          unfold AD_valid_state, refines_valid, FD_valid_state;
          intros; eauto
     end.
     edestruct H15.
     2: eexists; econstructor_recovery; [|eauto]; eauto.
     {
       instantiate (1:= Some inum).
       unfold AD_related_states, refines_related,
       FD_related_states in *; simpl;
       unfold refines, files_rep, files_crash_rep in *; simpl.
       do 2 eexists; intuition eauto.
     }
   }
   {
     exfalso; eapply extend_crashed_exfalso; eauto.
   }
   {
     exfalso; eapply extend_crashed_exfalso.
     eapply same_for_user_except_symmetry. eauto.
     all: eauto.
   }
   {
      match goal with
        [H: refines ?s1 ?x,
        H0: refines ?s2 ?x0,
        H1: same_for_user_except _ _ ?x ?x0,
        A : recovery_exec' _ _ _ _ _ _ _ |- _] =>
          eapply Termination_Sensitive_recover in A;
          try instantiate (1:= (fst s, (snd (snd s), snd (snd s)))) in A;
          unfold AD_valid_state, refines_valid, FD_valid_state;
          intros; eauto
     end.
     edestruct H15.
     2: eexists; econstructor_recovery; [|eauto]; eauto.
     {
       instantiate (1:= Some inum).
       unfold AD_related_states, refines_related,
       FD_related_states in *; simpl;
       unfold refines, files_rep, files_crash_rep in *; simpl.
       do 2 eexists; intuition eauto.
       {
         unfold same_for_user_except in *; cleanup.
         split; intros.
         unfold addrs_match_exactly in *; intros.
         destruct (addr_dec a1 inum);
         [repeat rewrite Mem.upd_eq; eauto; intuition congruence
         |repeat rewrite Mem.upd_ne; eauto; intuition congruence].
         split; intros.
         {
          destruct (addr_dec inum0 inum);
          [rewrite Mem.upd_eq in H5, H16; eauto; cleanup
         |rewrite Mem.upd_ne in H5, H16; eauto; cleanup].
         intuition.
         }
         {
          destruct (addr_dec inum0 inum);
          [rewrite Mem.upd_eq in H5, H4; eauto; cleanup
         |rewrite Mem.upd_ne in H5, H4; eauto; cleanup].
         unfold extend_file in *; simpl in *.
         eapply a0 in H7; eauto.
         cleanup; intuition eauto.
         repeat rewrite app_length; simpl; lia.
         }
       }
     }
   }
  }
  {
     intros.
     eapply_fresh TS_extend_inner in H7; eauto.
     cleanup.
     destruct ret1, x1; simpl in * ; try solve [intuition congruence].
     {
      eapply SameRetType.extend_inner_finished_oracle_eq in H7; eauto.
      cleanup.
      eexists.
      intuition eauto; cleanup; eauto.
     }
     {
      eexists.
      intuition eauto; cleanup; eauto.
     }
  }
}
Unshelve.
all: eauto.
Qed.


Require Import AutoSep Malloc.

Section adt.
  Variable P : W -> W -> HProp.
  Variable res : nat.

  Definition newS := SPEC("extra_stack") reserving res
    PRE[_] mallocHeap 0
    POST[R] P 0 R * mallocHeap 0.

  Definition deleteS := SPEC("extra_stack", "self") reserving res
    Al c,
    PRE[V] P c (V "self") * mallocHeap 0
    POST[_] mallocHeap 0.

  Definition readS := SPEC("extra_stack", "self") reserving res
    Al c,
    PRE[V] P c (V "self") * mallocHeap 0
    POST[R] [| R = c |] * P c (V "self") * mallocHeap 0.

  Definition writeS := SPEC("extra_stack", "self", "n") reserving res
    Al c,
    PRE[V] P c (V "self") * mallocHeap 0
    POST[_] P (V "n") (V "self") * mallocHeap 0.
End adt.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RealmSyncHandlerAux.Spec.
Require Import RealmSyncHandlerAux.Layer.
Require Import RealmSyncHandler.Code.handle_sysreg_access_trap.

Require Import RealmSyncHandler.LowSpecs.handle_sysreg_access_trap.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _assert_cond ↦ gensem assert_cond_spec
      ⊕ _handle_id_sysreg_trap ↦ gensem handle_id_sysreg_trap_spec
      ⊕ _handle_timer_sysreg_trap ↦ gensem handle_timer_sysreg_trap_spec
      ⊕ _handle_icc_el1_sysreg_trap ↦ gensem handle_icc_el1_sysreg_trap_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_assert_cond: block.
    Hypothesis h_assert_cond_s : Genv.find_symbol ge _assert_cond = Some b_assert_cond.
    Hypothesis h_assert_cond_p : Genv.find_funct_ptr ge b_assert_cond
                                 = Some (External (EF_external _assert_cond
                                                  (signature_of_type (Tcons tuint Tnil) tvoid cc_default))
                                        (Tcons tuint Tnil) tvoid cc_default).
    Local Opaque assert_cond_spec.

    Variable b_handle_id_sysreg_trap: block.
    Hypothesis h_handle_id_sysreg_trap_s : Genv.find_symbol ge _handle_id_sysreg_trap = Some b_handle_id_sysreg_trap.
    Hypothesis h_handle_id_sysreg_trap_p : Genv.find_funct_ptr ge b_handle_id_sysreg_trap
                                           = Some (External (EF_external _handle_id_sysreg_trap
                                                            (signature_of_type (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default))
                                                  (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default).
    Local Opaque handle_id_sysreg_trap_spec.

    Variable b_handle_timer_sysreg_trap: block.
    Hypothesis h_handle_timer_sysreg_trap_s : Genv.find_symbol ge _handle_timer_sysreg_trap = Some b_handle_timer_sysreg_trap.
    Hypothesis h_handle_timer_sysreg_trap_p : Genv.find_funct_ptr ge b_handle_timer_sysreg_trap
                                              = Some (External (EF_external _handle_timer_sysreg_trap
                                                               (signature_of_type (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default))
                                                     (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default).
    Local Opaque handle_timer_sysreg_trap_spec.

    Variable b_handle_icc_el1_sysreg_trap: block.
    Hypothesis h_handle_icc_el1_sysreg_trap_s : Genv.find_symbol ge _handle_icc_el1_sysreg_trap = Some b_handle_icc_el1_sysreg_trap.
    Hypothesis h_handle_icc_el1_sysreg_trap_p : Genv.find_funct_ptr ge b_handle_icc_el1_sysreg_trap
                                                = Some (External (EF_external _handle_icc_el1_sysreg_trap
                                                                 (signature_of_type (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default))
                                                       (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default).
    Local Opaque handle_icc_el1_sysreg_trap_spec.

    Lemma handle_sysreg_access_trap_body_correct:
      forall m d d' env le rec_base rec_offset esr
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTrec: PTree.get _rec le = Some (Vptr rec_base (Int.repr rec_offset)))
             (HPTesr: PTree.get _esr le = Some (Vlong esr))
             (Hspec: handle_sysreg_access_trap_spec0 (rec_base, rec_offset) (VZ64 (Int64.unsigned esr)) d = Some d'),
           exists le', (exec_stmt ge env le ((m, d): mem) handle_sysreg_access_trap_body E0 le' (m, d') Out_normal).
    Proof.
      solve_code_proof Hspec handle_sysreg_access_trap_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.BinInt.
Require Import coqutil.Map.Interface.
Require Import riscv.Utility.Monads.
Require Import riscv.Utility.Utility.
Require Import riscv.Spec.Decode.
Require Import riscv.Platform.Memory.
Require Import riscv.Spec.Machine.
Require Import riscv.Platform.RiscvMachine.
Require Import riscv.Utility.MkMachineWidth.

(* Note: Register 0 is not considered valid because it cannot be written *)
Definition valid_register(r: Register): Prop := (0 < r < 32)%Z.

Section Primitives.

  Context {width: Z} {BW: Bitwidth width} {word: word width} {word_ok: word.ok word}.
  Context {Registers: map.map Register word}.
  Context {mem: map.map word byte}.

  Context {M: Type -> Type}.
  Context {MM: Monad M}.

  Class PrimitivesParams(Machine: Type) := {
    (* Abstract predicate specifying when a monadic computation satisfies a
       postcondition when run on given initial machine *)
    mcomp_sat: forall {A: Type}, M A -> Machine -> (A -> Machine -> Prop) -> Prop;

    (* Tells whether the given value can be found in an uninitialized register.
       On instances supporting non-determinism, it returns True for all values.
       On instances without non-determinism, it only accepts a default value, eg 0 *)
    is_initial_register_value: word -> Prop;

    (* tells what happens if an n-byte read at a non-memory address is performed *)
    nonmem_load : forall (n: nat), SourceType -> word -> RiscvMachine -> (HList.tuple byte n -> RiscvMachine -> Prop) -> Prop;

    (* tells what happens if an n-byte write at a non-memory address is performed *)
    nonmem_store: forall (n: nat), SourceType -> word -> HList.tuple byte n -> RiscvMachine -> (RiscvMachine -> Prop) -> Prop;

    (* an invariant which is preserved by each primitive operation
       TODO it might also be useful to have invariants which are only preserved by whole
       instructions, such as eg the concrete nextPc = pc + 4 *)
    valid_machine: Machine -> Prop;
  }.

  Class mcomp_sat_spec{Machine: Type}(p: PrimitivesParams Machine): Prop := {
    spec_Bind{A B: Type}: forall (initialL: Machine) (post: B -> Machine -> Prop)
                                 (m: M A) (f : A -> M B),
        (exists mid: A -> Machine -> Prop,
            mcomp_sat m initialL mid /\
            (forall a middle, mid a middle -> mcomp_sat (f a) middle post)) <->
        mcomp_sat (Bind m f) initialL post;

    spec_Return{A: Type}: forall (initialL: Machine)
                                 (post: A -> Machine -> Prop) (a: A),
        post a initialL <->
        mcomp_sat (Return a) initialL post;
  }.

  (* monadic computations used for specifying the behavior of RiscvMachines should be "sane"
     in the sense that we never step to the empty set (that's not absence of failure, since
     failure is modeled as "steps to no set at all"), and that the trace of events is
     append-only, and that valid_machine is preserved *)
  Definition mcomp_sane{p: PrimitivesParams RiscvMachine}{A: Type}(comp: M A): Prop :=
    forall (st: RiscvMachine) (post: A -> RiscvMachine -> Prop),
      valid_machine st ->
      mcomp_sat comp st post ->
      (exists a st', post a st' /\ valid_machine st') /\
      (mcomp_sat comp st (fun a st' =>
         (post a st' /\ exists diff, st'.(getLog) = diff ++ st.(getLog)) /\ valid_machine st')).

  Context {RVM: RiscvProgram M word}.
  Context {RVS: @riscv.Spec.Machine.RiscvMachine M word _ _ RVM}.

  Class PrimitivesSane(p: PrimitivesParams RiscvMachine): Prop := {
    getRegister_sane: forall r, mcomp_sane (getRegister r);
    setRegister_sane: forall r v, mcomp_sane (setRegister r v);
    loadByte_sane: forall kind addr, mcomp_sane (loadByte kind addr);
    loadHalf_sane: forall kind addr, mcomp_sane (loadHalf kind addr);
    loadWord_sane: forall kind addr, mcomp_sane (loadWord kind addr);
    loadDouble_sane: forall kind addr, mcomp_sane (loadDouble kind addr);
    storeByte_sane: forall kind addr v, mcomp_sane (storeByte kind addr v);
    storeHalf_sane: forall kind addr v, mcomp_sane (storeHalf kind addr v);
    storeWord_sane: forall kind addr v, mcomp_sane (storeWord kind addr v);
    storeDouble_sane: forall kind addr v, mcomp_sane (storeDouble kind addr v);
    makeReservation_sane: forall addr, mcomp_sane (makeReservation addr);
    clearReservation_sane: forall addr, mcomp_sane (clearReservation addr);
    checkReservation_sane: forall addr, mcomp_sane (checkReservation addr);
    getCSRField_sane: forall f, mcomp_sane (getCSRField f);
    setCSRField_sane: forall f v, mcomp_sane (setCSRField f v);
    getPrivMode_sane: mcomp_sane getPrivMode;
    setPrivMode_sane: forall m, mcomp_sane (setPrivMode m);
    fence_sane: forall a b, mcomp_sane (fence a b);
    getPC_sane: mcomp_sane getPC;
    setPC_sane: forall newPc, mcomp_sane (setPC newPc);
    endCycleNormal_sane: mcomp_sane endCycleNormal;
    endCycleEarly_sane: forall A, mcomp_sane (@endCycleEarly _ _ _ _ _ A);
  }.

  Definition spec_load{p: PrimitivesParams RiscvMachine}(n: nat)
             (riscv_load: SourceType -> word -> M (HList.tuple byte n))
             (mem_load: mem -> word -> option (HList.tuple byte n))
    : Prop :=
    forall initialL addr (kind: SourceType) (post: HList.tuple byte n -> RiscvMachine -> Prop),
      (kind = Fetch -> isXAddr4 addr initialL.(getXAddrs)) /\
      ((exists v, mem_load initialL.(getMem) addr = Some v /\
                  post v initialL) \/
       (mem_load initialL.(getMem) addr = None /\
        nonmem_load n kind addr initialL post)) ->
      mcomp_sat (riscv_load kind addr) initialL post.

  (* After an address has been written, we make it non-executable, to make sure a processor
     with an instruction cache won't execute a stale instruction. *)
  Fixpoint invalidateWrittenXAddrs(nBytes: nat)(addr: word)(xAddrs: XAddrs): XAddrs :=
    match nBytes with
    | O => xAddrs
    | S n => removeXAddr addr (invalidateWrittenXAddrs n (word.add addr (word.of_Z 1)) xAddrs)
    end.

  Definition spec_store{p: PrimitivesParams RiscvMachine}(n: nat)
             (riscv_store: SourceType -> word -> HList.tuple byte n -> M unit)
             (mem_store: mem -> word -> HList.tuple byte n -> option mem)
             : Prop :=
    forall initialL addr v (kind: SourceType) (post: unit -> RiscvMachine -> Prop),
      (exists m', mem_store initialL.(getMem) addr v = Some m' /\
                  post tt (withXAddrs (invalidateWrittenXAddrs n addr initialL.(getXAddrs))
                          (withMem m' initialL))) \/
      (mem_store initialL.(getMem) addr v = None /\
       nonmem_store n kind addr v initialL (post tt)) ->
      mcomp_sat (riscv_store kind addr v) initialL post.

  (* primitives_params is a paramater rather than a field because Primitives lives in Prop and
     is opaque, but the fields of primitives_params need to be visible *)
  Class Primitives(primitives_params: PrimitivesParams RiscvMachine): Prop := {
    mcomp_sat_ok :> mcomp_sat_spec primitives_params;
    primitives_sane :> PrimitivesSane primitives_params;

    spec_getRegister: forall (initialL: RiscvMachine) (x: Register)
                             (post: word -> RiscvMachine -> Prop),
        (valid_register x /\
         match map.get initialL.(getRegs) x with
         | Some v => post v initialL
         | None => forall v, is_initial_register_value v -> post v initialL
         end) \/
        (x = Register0 /\ post (word.of_Z 0) initialL) ->
        mcomp_sat (getRegister x) initialL post;

    spec_setRegister: forall initialL x v (post: unit -> RiscvMachine -> Prop),
      (valid_register x /\ post tt (withRegs (map.put initialL.(getRegs) x v) initialL) \/
       x = Register0 /\ post tt initialL) ->
      mcomp_sat (setRegister x v) initialL post;

    spec_loadByte: spec_load 1 (Machine.loadByte (RiscvProgram := RVM)) Memory.loadByte;
    spec_loadHalf: spec_load 2 (Machine.loadHalf (RiscvProgram := RVM)) Memory.loadHalf;
    spec_loadWord: spec_load 4 (Machine.loadWord (RiscvProgram := RVM)) Memory.loadWord;
    spec_loadDouble: spec_load 8 (Machine.loadDouble (RiscvProgram := RVM)) Memory.loadDouble;

    spec_storeByte: spec_store 1 (Machine.storeByte (RiscvProgram := RVM)) Memory.storeByte;
    spec_storeHalf: spec_store 2 (Machine.storeHalf (RiscvProgram := RVM)) Memory.storeHalf;
    spec_storeWord: spec_store 4 (Machine.storeWord (RiscvProgram := RVM)) Memory.storeWord;
    spec_storeDouble: spec_store 8 (Machine.storeDouble (RiscvProgram := RVM)) Memory.storeDouble;

    spec_getPC: forall initialL (post: word -> RiscvMachine -> Prop),
        post initialL.(getPc) initialL ->
        mcomp_sat getPC initialL post;

    spec_setPC: forall initialL v (post: unit -> RiscvMachine -> Prop),
        post tt (withNextPc v initialL) ->
        mcomp_sat (setPC v) initialL post;

    spec_endCycleNormal: forall initialL (post: unit -> RiscvMachine -> Prop),
        post tt (withPc     initialL.(getNextPc)
                (withNextPc (word.add initialL.(getNextPc) (word.of_Z 4))
                            initialL)) ->
        mcomp_sat endCycleNormal initialL post;
  }.

End Primitives.

Arguments PrimitivesParams {_ _ _ _ _} M Machine.