(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Postorder renumbering of RTL control-flow graphs. *)

Require Import Coqlib Maps Postorder.
Require Import AST Linking.
Require Import Values Memory Globalenvs Events Smallstep.
Require Import Op Registers RTL Renumber.

Definition match_prog (p tp: RTL.program) :=
  match_program (fun ctx f tf => tf = transf_fundef f) eq p tp.

Lemma transf_program_match:
  forall p, match_prog p (transf_program p).
Proof.
(* Goal: forall (S1 S2 : state) (r : Integers.Int.int) (_ : match_states S1 S2) (_ : final_state S1 r), final_state S2 r *)
  intros. eapply match_transform_program; eauto.
Qed.

Section PRESERVATION.

Variables prog tprog: program.
Hypothesis TRANSL: match_prog prog tprog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma functions_translated:
  forall v f,
  Genv.find_funct ge v = Some f ->
  Genv.find_funct tge v = Some (transf_fundef f).
Proof (Genv.find_funct_transf TRANSL).

Lemma function_ptr_translated:
  forall v f,
  Genv.find_funct_ptr ge v = Some f ->
  Genv.find_funct_ptr tge v = Some (transf_fundef f).
Proof (Genv.find_funct_ptr_transf TRANSL).

Lemma symbols_preserved:
  forall id,
  Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof (Genv.find_symbol_transf TRANSL).

Lemma senv_preserved:
  Senv.equiv ge tge.
Proof (Genv.senv_transf TRANSL).

Lemma sig_preserved:
  forall f, funsig (transf_fundef f) = funsig f.
Proof.
(* Goal: forall f : fundef, @eq signature (funsig (transf_fundef f)) (funsig f) *)
  destruct f; reflexivity.
Qed.

Lemma find_function_translated:
  forall ros rs fd,
  find_function ge ros rs = Some fd ->
  find_function tge ros rs = Some (transf_fundef fd).
Proof.
(* Goal: forall (S1 S2 : state) (r : Integers.Int.int) (_ : match_states S1 S2) (_ : final_state S1 r), final_state S2 r *)
  unfold find_function; intros. destruct ros as [r|id].
(* Goal: @eq (option fundef) (@Genv.find_funct fundef unit tge (Regmap.get val r rs)) (@Some fundef (transf_fundef fd)) *)
(* Goal: @eq (option fundef) match @Genv.find_symbol fundef unit tge id with | Some b => @Genv.find_funct_ptr fundef unit tge b | None => @None fundef end (@Some fundef (transf_fundef fd)) *)
  eapply functions_translated; eauto.
(* Goal: @eq (option fundef) match @Genv.find_symbol fundef unit tge id with | Some b => @Genv.find_funct_ptr fundef unit tge b | None => @None fundef end (@Some fundef (transf_fundef fd)) *)
  rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try congruence.
(* Goal: @eq (option fundef) (@Genv.find_funct_ptr fundef unit tge b) (@Some fundef (transf_fundef fd)) *)
  eapply function_ptr_translated; eauto.
Qed.

(** Effect of an injective renaming of nodes on a CFG. *)

Section RENUMBER.

Variable f: PTree.t positive.

Hypothesis f_inj: forall x1 x2 y, f!x1 = Some y -> f!x2 = Some y -> x1 = x2.

Lemma renum_cfg_nodes:
  forall c x y i,
  c!x = Some i -> f!x = Some y -> (renum_cfg f c)!y = Some(renum_instr f i).
Proof.
  set (P := fun (c c': code) =>
              forall x y i, c!x = Some i -> f!x = Some y -> c'!y = Some(renum_instr f i)).
(* Goal: forall (c : PTree.t instruction) (x y : positive) (i : instruction) (_ : @eq (option instruction) (@PTree.get instruction x c) (@Some instruction i)) (_ : @eq (option positive) (@PTree.get positive x f) (@Some positive y)), @eq (option instruction) (@PTree.get instruction y (renum_cfg f c)) (@Some instruction (renum_instr f i)) *)
  intros c0. change (P c0 (renum_cfg f c0)). unfold renum_cfg.
(* Goal: forall (S1 S2 : state) (r : Integers.Int.int) (_ : match_states S1 S2) (_ : final_state S1 r), final_state S2 r *)
  apply PTree_Properties.fold_rec; unfold P; intros.
  (* extensionality *)
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
(* Goal: @eq (option instruction) (@PTree.get instruction y (PTree.empty instruction)) (@Some instruction (renum_instr f i)) *)
(* Goal: @eq (option instruction) (@PTree.get instruction y (renum_node f a k v)) (@Some instruction (renum_instr f i)) *)
  eapply H0; eauto. rewrite H; auto.
  (* base *)
(* Goal: @eq (option instruction) (@PTree.get instruction y (PTree.empty instruction)) (@Some instruction (renum_instr f i)) *)
(* Goal: @eq (option instruction) (@PTree.get instruction y (renum_node f a k v)) (@Some instruction (renum_instr f i)) *)
  rewrite PTree.gempty in H; congruence.
  (* induction *)
(* Goal: @eq (option instruction) (@PTree.get instruction y (renum_node f a k v)) (@Some instruction (renum_instr f i)) *)
  rewrite PTree.gsspec in H2. unfold renum_node. destruct (peq x k).
(* Goal: @eq (option instruction) (@PTree.get instruction y match @PTree.get positive k f with | Some pc' => @PTree.set instruction pc' (renum_instr f v) a | None => a end) (@Some instruction (renum_instr f i)) *)
(* Goal: @eq (option instruction) (@PTree.get instruction y match @PTree.get positive k f with | Some pc' => @PTree.set instruction pc' (renum_instr f v) a | None => a end) (@Some instruction (renum_instr f i)) *)
  inv H2. rewrite H3. apply PTree.gss.
(* Goal: @eq (option instruction) (@PTree.get instruction y match @PTree.get positive k f with | Some pc' => @PTree.set instruction pc' (renum_instr f v) a | None => a end) (@Some instruction (renum_instr f i)) *)
  destruct f!k as [y'|] eqn:?.
(* Goal: @eq (option instruction) (@PTree.get instruction y (@PTree.set instruction y' (renum_instr f v) a)) (@Some instruction (renum_instr f i)) *)
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  rewrite PTree.gso. eauto. red; intros; subst y'. elim n. eapply f_inj; eauto.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eauto.
Qed.

End RENUMBER.

Definition pnum (f: function) := postorder (successors_map f) f.(fn_entrypoint).

Definition reach (f: function) (pc: node) := reachable (successors_map f) f.(fn_entrypoint) pc.

Lemma transf_function_at:
  forall f pc i,
  f.(fn_code)!pc = Some i ->
  reach f pc ->
  (transf_function f).(fn_code)!(renum_pc (pnum f) pc) = Some(renum_instr (pnum f) i).
Proof.
(* Goal: forall (S1 S2 : state) (r : Integers.Int.int) (_ : match_states S1 S2) (_ : final_state S1 r), final_state S2 r *)
  intros.
(* Goal: @eq (option instruction) (@PTree.get instruction (renum_pc (pnum f) pc) (fn_code (transf_function f))) (@Some instruction (renum_instr (pnum f) i)) *)
  destruct (postorder_correct (successors_map f) f.(fn_entrypoint)) as [A B].
(* Goal: @eq (option instruction) (@PTree.get instruction (renum_pc (pnum f) pc) (fn_code (transf_function f))) (@Some instruction (renum_instr (pnum f) i)) *)
  fold (pnum f) in *.
(* Goal: @eq (option instruction) (@PTree.get instruction (renum_pc (pnum f) pc) (fn_code (transf_function f))) (@Some instruction (renum_instr (pnum f) i)) *)
  unfold renum_pc. destruct (pnum f)! pc as [pc'|] eqn:?.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  simpl. eapply renum_cfg_nodes; eauto.
(* Goal: not (@eq (option (list Postorder.node)) (@option_map instruction (list node) successors_instr (@Some instruction i)) (@None (list Postorder.node))) *)
  elim (B pc); auto. unfold successors_map. rewrite PTree.gmap1. rewrite H. simpl. congruence.
Qed.

Ltac TR_AT :=
  match goal with
  | [ A: (fn_code _)!_ = Some _ , B: reach _ _ |- _ ] =>
        generalize (transf_function_at _ _ _ A B); simpl renum_instr; intros
  end.

Lemma reach_succ:
  forall f pc i s,
  f.(fn_code)!pc = Some i -> In s (successors_instr i) ->
  reach f pc -> reach f s.
Proof.
(* Goal: forall (S1 S2 : state) (r : Integers.Int.int) (_ : match_states S1 S2) (_ : final_state S1 r), final_state S2 r *)
  unfold reach; intros. econstructor; eauto.
(* Goal: @eq (option (list Postorder.node)) (@PTree.get (list Postorder.node) pc (successors_map f)) (@Some (list Postorder.node) (successors_instr i)) *)
  unfold successors_map. rewrite PTree.gmap1. rewrite H. auto.
Qed.

Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop :=
  | match_frames_intro: forall res f sp pc rs
        (REACH: reach f pc),
      match_frames (Stackframe res f sp pc rs)
                   (Stackframe res (transf_function f) sp (renum_pc (pnum f) pc) rs).

Inductive match_states: RTL.state -> RTL.state -> Prop :=
  | match_regular_states: forall stk f sp pc rs m stk'
        (STACKS: list_forall2 match_frames stk stk')
        (REACH: reach f pc),
      match_states (State stk f sp pc rs m)
                   (State stk' (transf_function f) sp (renum_pc (pnum f) pc) rs m)
  | match_callstates: forall stk f args m stk'
        (STACKS: list_forall2 match_frames stk stk'),
      match_states (Callstate stk f args m)
                   (Callstate stk' (transf_fundef f) args m)
  | match_returnstates: forall stk v m stk'
        (STACKS: list_forall2 match_frames stk stk'),
      match_states (Returnstate stk v m)
                   (Returnstate stk' v m).

Lemma step_simulation:
  forall S1 t S2, RTL.step ge S1 t S2 ->
  forall S1', match_states S1 S1' ->
  exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'.
Proof.
  induction 1; intros S1' MS; inv MS; try TR_AT.
(* nop *)
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  econstructor; split. eapply exec_Inop; eauto.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  constructor; auto. eapply reach_succ; eauto. simpl; auto.
(* op *)
  econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_Iop; eauto.
  instantiate (1 := v). rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  constructor; auto. eapply reach_succ; eauto. simpl; auto.
(* load *)
  econstructor; split.
  assert (eval_addressing tge sp addr rs ## args = Some a).
  rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_Iload; eauto.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  constructor; auto. eapply reach_succ; eauto. simpl; auto.
(* store *)
  econstructor; split.
  assert (eval_addressing tge sp addr rs ## args = Some a).
  rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_Istore; eauto.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  constructor; auto. eapply reach_succ; eauto. simpl; auto.
(* call *)
  econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_Icall with (fd := transf_fundef fd); eauto.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
    eapply find_function_translated; eauto.
    apply sig_preserved.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  constructor. constructor; auto. constructor. eapply reach_succ; eauto. simpl; auto.
(* tailcall *)
  econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_Itailcall with (fd := transf_fundef fd); eauto.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
    eapply find_function_translated; eauto.
    apply sig_preserved.
(* Goal: @eq (option (list Postorder.node)) (@option_map instruction (list node) successors_instr (@Some instruction i)) (@Some (list Postorder.node) (successors_instr i)) *)
  constructor. auto.
(* builtin *)
  econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_Ibuiltin; eauto.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
    eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
    eapply external_call_symbols_preserved; eauto. apply senv_preserved.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  constructor; auto. eapply reach_succ; eauto. simpl; auto.
(* cond *)
  econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_Icond; eauto.
  replace (if b then renum_pc (pnum f) ifso else renum_pc (pnum f) ifnot)
     with (renum_pc (pnum f) (if b then ifso else ifnot)).
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  constructor; auto. eapply reach_succ; eauto. simpl. destruct b; auto.
(* Goal: @eq (option (list Postorder.node)) (@option_map instruction (list node) successors_instr (@Some instruction i)) (@Some (list Postorder.node) (successors_instr i)) *)
  destruct b; auto.
(* jumptbl *)
  econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_Ijumptable; eauto. rewrite list_nth_z_map. rewrite H1. simpl; eauto.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  constructor; auto. eapply reach_succ; eauto. simpl. eapply list_nth_z_in; eauto.
(* return *)
  econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_Ireturn; eauto.
(* Goal: @eq (option (list Postorder.node)) (@option_map instruction (list node) successors_instr (@Some instruction i)) (@Some (list Postorder.node) (successors_instr i)) *)
  constructor; auto.
(* internal function *)
(* Goal: not (@eq (option (list Postorder.node)) (@option_map instruction (list node) successors_instr (@Some instruction i)) (@None (list Postorder.node))) *)
  simpl. econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_function_internal; eauto.
(* Goal: @eq (option (list Postorder.node)) (@option_map instruction (list node) successors_instr (@Some instruction i)) (@Some (list Postorder.node) (successors_instr i)) *)
  constructor; auto. unfold reach. constructor.
(* external function *)
  econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_function_external; eauto.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
    eapply external_call_symbols_preserved; eauto. apply senv_preserved.
(* Goal: @eq (option (list Postorder.node)) (@option_map instruction (list node) successors_instr (@Some instruction i)) (@Some (list Postorder.node) (successors_instr i)) *)
  constructor; auto.
(* return *)
(* Goal: final_state (Returnstate stk' (Vint r) m) r *)
  inv STACKS. inv H1.
  econstructor; split.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
  eapply exec_return; eauto.
(* Goal: @eq (option (list Postorder.node)) (@option_map instruction (list node) successors_instr (@Some instruction i)) (@Some (list Postorder.node) (successors_instr i)) *)
  constructor; auto.
Qed.

Lemma transf_initial_states:
  forall S1, RTL.initial_state prog S1 ->
  exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2.
Proof.
(* Goal: forall (S1 S2 : state) (r : Integers.Int.int) (_ : match_states S1 S2) (_ : final_state S1 r), final_state S2 r *)
  intros. inv H. econstructor; split.
(* Goal: final_state (Returnstate (@nil stackframe) (Vint r) m) r *)
  econstructor.
(* Goal: @eq (option instruction) (@PTree.get instruction y a) (@Some instruction (renum_instr f i)) *)
    eapply (Genv.init_mem_transf TRANSL); eauto.
(* Goal: @eq (option fundef) match @Genv.find_symbol fundef unit tge id with | Some b => @Genv.find_funct_ptr fundef unit tge b | None => @None fundef end (@Some fundef (transf_fundef fd)) *)
    rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto.
(* Goal: @eq (option fundef) (@Genv.find_funct_ptr fundef unit tge b) (@Some fundef (transf_fundef fd)) *)
    eapply function_ptr_translated; eauto.
    rewrite <- H3; apply sig_preserved.
(* Goal: final_state (Returnstate (@nil stackframe) (Vint r) m) r *)
  constructor. constructor.
Qed.

Lemma transf_final_states:
  forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r.
Proof.
(* Goal: forall (S1 S2 : state) (r : Integers.Int.int) (_ : match_states S1 S2) (_ : final_state S1 r), final_state S2 r *)
  intros. inv H0. inv H. inv STACKS. constructor.
Qed.

Theorem transf_program_correct:
  forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
Proof.
  eapply forward_simulation_step.
  apply senv_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  exact step_simulation.
Qed.

End PRESERVATION.







