Library compcert

Require Import base.
Require Import iface.

Add LoadPath "../../compcert-1.11/lib".
Add LoadPath "../../compcert-1.11/common".
Add LoadPath "../../compcert-1.11/flocq/Core".
Add LoadPath "../../compcert-1.11/flocq/Calc".
Add LoadPath "../../compcert-1.11/flocq/Prop".
Add LoadPath "../../compcert-1.11/flocq/Appli".

Require Import Events.
Require Import Smallstep.
Require Import AST.
Require Import Integers.
Require Import Globalenvs.

Import CI.

Inductive compcert_obs :=
  | obs_event : event -> compcert_obs
  | obs_terminate : int -> compcert_obs.

Instance compcert_observations : ObservationSystem :=
{| O := compcert_obs
 ; observations_inhabited := obs_terminate Int.zero
 |}.

Inductive match_ev : option compcert_obs -> list event -> Prop :=
  | match_ev_none : match_ev None nil
  | match_ev_some : forall e, match_ev (Some (obs_event e)) (e::nil).

Definition immed_safe (sem:semantics) (x:Smallstep.state sem) :=
  (exists i, Smallstep.final_state sem x i)
  \/
  (exists t, exists x', Smallstep.step sem (globalenv sem) x t x').

Inductive semantics_lts_state (sem:semantics) :=
  | run : Smallstep.state sem -> semantics_lts_state sem
  | done : semantics_lts_state sem.

Inductive semantics_lts_step (sem:semantics) :
  semantics_lts_state sem -> option O -> lift (semantics_lts_state sem) -> Prop :=

  | sem_lts_step_ok : forall x o t x',
      match_ev o t ->
      Smallstep.step sem (globalenv sem) x t x' ->
      semantics_lts_step sem (run sem x) o (into (run sem x'))
  
  | sem_lts_step_wrong : forall x,
      ~immed_safe sem x ->
      semantics_lts_step sem (run sem x) None (mho _)

  | sem_lts_step_term : forall x i,
      final_state sem x i ->
      semantics_lts_step sem (run sem x) (Some (obs_terminate i)) (into (done _)).

Definition semantics_LTS (sem:semantics) : LTS :=
  Build_LTS (semantics_lts_state sem) (semantics_lts_step sem).

Lemma plus_decompose : forall L x t x',
   (length t <= 1) ->
   Plus L x t x' ->
   exists a1, exists a2,
      Star L x E0 a1 /\
      Step L a1 t a2 /\
      Star L a2 E0 x'.

Definition immed_safe_dec (L:semantics) :=
  forall x:Smallstep.state L,
    immed_safe L x \/ ~immed_safe L x.

Section forward_sim_to_beh_refine.
  Variables L1 L2 : semantics.
  Variable fsim : forward_simulation L1 L2.

  Hypothesis safe_dec : immed_safe_dec L1.
  Hypothesis L1recep : receptive L1.
  Hypothesis L2determ : determinate L2.

  Definition fsim_refine x y :=
      match x, y with
      | mho, _ => True
      | into (run x), mho => exists q, exists y,
           ~immed_safe L2 y /\
           fsim_match_states fsim q x y
      | into (run x), into (run y) =>
          exists y', (Star L2 y E0 y' \/ Star L2 y' E0 y) /\
          exists q, fsim_match_states fsim q x y'
      | into done, into done => True
      | _, _ => False
      end.

  Lemma star_must_step_star L : forall x x',
    Star L x E0 x' ->
    must_step_star (semantics_LTS L) (into (run L x)) (into (run L x')).

  Lemma compcert_branch_forward_sim_run1 : forall q x y0 y1,
    fsim_match_states fsim q x y0 ->
    Star L2 y0 E0 y1 ->
    branch_forward_ind_no_stutter
       (semantics_LTS L1) (semantics_LTS L2) fsim_refine
       (into (run L1 x)) (into (run L2 y1)).

  Lemma compcert_branch_forward_sim_run2 : forall q x y0 y1,
    fsim_match_states fsim q x y0 ->
    Star L2 y1 E0 y0 ->
    branch_forward_ind_no_stutter
     (semantics_LTS L1) (semantics_LTS L2) fsim_refine
     (into (run L1 x)) (into (run L2 y1)).

  Lemma compcert_forward_sim :
    refinement branch_forward_ind_no_stutter
      (semantics_LTS L1) (semantics_LTS L2) fsim_refine.

  Lemma compcert_fsim_match_push : forall q x y0 y1,
    fsim_match_states fsim q x y0 ->
    Star L2 y0 E0 y1 ->
    (exists x', exists x'', exists ymid, exists y',exists y'', exists y''', exists q', exists e,
      Star L1 x E0 x' /\ Step L1 x' (e::nil) x'' /\
      Star L2 y0 E0 ymid /\ Star L2 ymid E0 y1 /\
      Star L2 y1 E0 y' /\ Step L2 y' (e::nil) y'' /\ Star L2 y'' E0 y''' /\
      fsim q' x' ymid)
    \/
    (exists x', exists y', exists q',
      Star L1 x E0 x' /\ fsim q' x' y' /\
      ((~immed_safe L1 x' /\ Star L2 y' E0 y1)
      \/
      (exists i, final_state L1 x' i /\ Star L2 y' E0 y1)
      \/
      (Star L2 y1 E0 y'))).

  Lemma compcert_branch_backward_sim_run0 : forall q x x1 y
    (Hx:exists q, exists y0, fsim q x y0 /\ Star L2 y0 E0 y),
    Star L1 x E0 x1 ->
    fsim q x1 y ->
    branch_backward_ind_no_stutter (semantics_LTS L1)
       (semantics_LTS L2) fsim_refine (into (run L1 x))
       (into (run L2 y)).

  Lemma compcert_branch_backward_sim_run1 : forall q x y0 y1,
    fsim_match_states fsim q x y0 ->
    Star L2 y0 E0 y1 ->
    branch_backward_ind_no_stutter
       (semantics_LTS L1) (semantics_LTS L2) fsim_refine
       (into (run L1 x)) (into (run L2 y1)).

  Lemma compcert_branch_backward_sim_run2 : forall q x y0 y1,
    fsim_match_states fsim q x y0 ->
    Star L2 y1 E0 y0 ->
    branch_backward_ind_no_stutter
       (semantics_LTS L1) (semantics_LTS L2) fsim_refine
       (into (run L1 x)) (into (run L2 y1)).

  Lemma compcert_backward_sim :
    refinement branch_backward_ind_no_stutter
      (semantics_LTS L1) (semantics_LTS L2) fsim_refine.

  Lemma compcert_refinement :
    refinement branch_ind_no_stutter (semantics_LTS L1) (semantics_LTS L2) fsim_refine.

  Lemma matching_states_refine :
    forall q x y, fsim q x y ->
      refines branch_ind (semantics_LTS L1) (semantics_LTS L2)
         (into (run L1 x)) (into (run L2 y)).

  Lemma initial_states_refine :
    forall i1, initial_state L1 i1 ->
      exists i2, initial_state L2 i2 /\
        refines branch_ind (semantics_LTS L1) (semantics_LTS L2)
           (into (run L1 i1)) (into (run L2 i2)).
End forward_sim_to_beh_refine.

Add LoadPath "../../compcert-1.11/ia32".
Add LoadPath "../../compcert-1.11/ia32/standard".
Add LoadPath "../../compcert-1.11/cfrontend".
Add LoadPath "../../compcert-1.11/backend".
Add LoadPath "../../compcert-1.11/lib".
Add LoadPath "../../compcert-1.11/driver".

Require Cstrategy.
Require Asm.
Require Compiler.

Let C p := atomic (Cstrategy.semantics p).
Let A p := Asm.semantics p.

Theorem CompCert_main_pass_correctness :
  forall p tp, Compiler.transf_c_program p = Errors.OK tp ->
    forall i1, initial_state (C p) i1 ->
      exists i2, initial_state (A tp) i2 /\
        refines branch_ind (semantics_LTS (C p)) (semantics_LTS (A tp))
           (into (run (C p) i1)) (into (run (A tp) i2)).