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