(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*      Laurence Rideau, INRIA Sophia-Antipolis-M\u00e9diterran\u00e9e           *)
(*      Bernard Paul Serpette, INRIA Sophia-Antipolis-M\u00e9diterran\u00e9e     *)
(*      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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Translation of parallel moves into sequences of individual moves *)

(** The ``parallel move'' problem, also known as ``parallel assignment'',
  is the following.  We are given a list of (source, destination) pairs
  of locations.  The goal is to find a sequence of elementary
  moves ([loc <- loc] assignments) such that, at the end of the sequence,
  location [dst] contains the value of location [src] at the beginning of
  the sequence, for each ([src], [dst]) pairs in the given problem.
  Moreover, other locations should keep their values, except one register
  of each type, which can be used as temporaries in the generated sequences.

  The parallel move problem is trivial if the sources and destinations do
  not overlap.  For instance,
<<
  (R1, R2) <- (R3, R4)     becomes    R1 <- R3; R2 <- R4
>>
  However, arbitrary overlap is allowed between sources and destinations.
  This requires some care in ordering the individual moves, as in
<<
  (R1, R2) <- (R3, R1)     becomes    R2 <- R1; R1 <- R3
>>
  Worse, cycles (permutations) can require the use of temporaries, as in
<<
  (R1, R2, R3) <- (R2, R3, R1)   becomes   T <- R1; R1 <- R2; R2 <- R3; R3 <- T;
>>
  An amazing fact is that for any parallel move problem, at most one temporary
  (or in our case one integer temporary and one float temporary) is needed.

  The development in this section was designed by Laurence Rideau and
  Bernard Serpette.  It is described in the paper
  ``Tilting at windmills with Coq: Formal verification of
  a compilation algorithm for parallel moves'',
  ##
  http://hal.inria.fr/inria-00176007
  ##
*)

Require Import Relations.
Require Import Axioms.
Require Import Coqlib.
Require Recdef.

Section PARMOV.

(** * Registers, moves, and their semantics *)

(** The development is parameterized by the type of registers,
    equipped with a decidable equality. *)

Variable reg: Type.
Variable reg_eq : forall (r1 r2: reg), {r1=r2} + {r1<>r2}.

(** The [temp] function maps every register [r] to the register that
    should be used to save the value of [r] temporarily while performing
    a cyclic assignment involving [r].  In the simplest case, there is
    only one such temporary register [rtemp] and [temp] is the constant
    function [fun r => rtemp].  In more realistic cases, different temporary
    registers can be used to hold different values.  In the case of Compcert,
    we have two temporary registers, one for integer values and the other
    for floating-point values, and [temp] returns the appropriate temporary
    depending on the type of its argument. *)

Variable temp: reg -> reg.

Definition is_temp (r: reg): Prop := exists s, r = temp s.

(** A set of moves is a list of pairs of registers, of the form
    (source, destination). *)

Definition moves := (list (reg * reg))%type.  (* src -> dst *)

Definition srcs (m: moves) := List.map (@fst reg reg) m.
Definition dests (m: moves) := List.map (@snd reg reg) m.

(** ** Semantics of moves *)

(** The dynamic  semantics of moves is given in terms of environments.
    An environment is a mapping of registers to their current values. *)

Variable val: Type.
Definition env := reg -> val.

Lemma env_ext:
  forall (e1 e2: env),
  (forall r, e1 r = e2 r) -> e1 = e2.
Proof (@extensionality reg val).

(** The main operation over environments is update: it assigns
  a value [v] to a register [r] and preserves the values of other
  registers. *)

Definition update (r: reg) (v: val) (e: env) : env :=
  fun r' => if reg_eq r' r then v else e r'.

Lemma update_s:
  forall r v e, update r v e r = v.
Proof.
  unfold update; intros. destruct (reg_eq r r). auto. congruence.
Qed.

Lemma update_o:
  forall r v e r', r' <> r -> update r v e r' =  e r'.
Proof.
  unfold update; intros. destruct (reg_eq r' r). congruence. auto.
Qed.

Lemma update_ident:
  forall r e, update r (e r) e = e.
Proof.
  intros. apply env_ext; intro. unfold update. destruct (reg_eq r0 r); congruence.
Qed.

Lemma update_commut:
  forall r1 v1 r2 v2 e,
  r1 <> r2 ->
  update r1 v1 (update r2 v2 e) = update r2 v2 (update r1 v1 e).
Proof.
  intros. apply env_ext; intro; unfold update.
  destruct (reg_eq r r1); destruct (reg_eq r r2); auto.
  congruence.
Qed.

Lemma update_twice:
  forall r v e,
  update r v (update r v e) = update r v e.
Proof.
  intros. apply env_ext; intro; unfold update.
  destruct (reg_eq r0 r); auto.
Qed.

(** A list of moves [(src1, dst1), ..., (srcN, dstN)] can be given
  three different semantics, as environment transformers.
  The first semantics corresponds to a parallel assignment:
  [dst1, ..., dstN] are set to the initial values of [src1, ..., srcN]. *)

Fixpoint exec_par (m: moves) (e: env) {struct m}: env :=
  match m with
  | nil => e
  | (s, d) :: m' => update d (e s) (exec_par m' e)
  end.

(** The second semantics corresponds to a sequence of individual
  assignments: first, [dst1] is set to the initial value of [src1];
  then, [dst2] is set to the current value of [src2] after the first
  assignment; etc. *)

Fixpoint exec_seq (m: moves) (e: env) {struct m}: env :=
  match m with
  | nil => e
  | (s, d) :: m' => exec_seq m' (update d (e s) e)
  end.

(** The third semantics is also sequential, but executes the moves
  in reverse order, starting with [srcN, dstN] and finishing with
  [src1, dst1]. *)

Fixpoint exec_seq_rev (m: moves) (e: env) {struct m}: env :=
  match m with
  | nil => e
  | (s, d) :: m' =>
      let e' := exec_seq_rev m' e in
      update d (e' s) e'
  end.

(** * Specification of the non-deterministic algorithm *)

(** Rideau and Serpette's parallel move compilation algorithm is first
   specified as a non-deterministic set of rewriting rules operating
   over triples [(mu, sigma, tau)] of moves.  We define these rules
   as an inductive predicate [transition] relating triples of moves,
   and its reflexive transitive closure [transitions]. *)

Inductive state: Type :=
  State (mu: moves) (sigma: moves) (tau: moves) : state.

Definition no_read (mu: moves) (d: reg) : Prop :=
  ~In d (srcs mu).

Inductive transition: state -> state -> Prop :=
  | tr_nop: forall mu1 r mu2 sigma tau,
      transition (State (mu1 ++ (r, r) :: mu2) sigma tau)
                 (State (mu1 ++ mu2) sigma tau)
  | tr_start: forall mu1 s d mu2 tau,
      transition (State (mu1 ++ (s, d) :: mu2) nil tau)
                 (State (mu1 ++ mu2) ((s, d) :: nil) tau)
  | tr_push: forall mu1 d r mu2 s sigma tau,
      transition (State (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau)
                 (State (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau)
  | tr_loop: forall mu sigma s d tau,
      transition (State mu (sigma ++ (s, d) :: nil) tau)
                 (State mu (sigma ++ (temp s, d) :: nil) ((s, temp s) :: tau))
  | tr_pop: forall mu s0 d0 s1 d1 sigma tau,
      no_read mu d1 -> d1 <> s0 ->
      transition (State mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau)
                 (State mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau))
  | tr_last: forall mu s d tau,
      no_read mu d ->
      transition (State mu ((s, d) :: nil) tau)
                 (State mu nil ((s, d) :: tau)).

Definition transitions: state -> state -> Prop :=
  clos_refl_trans state transition.

(** ** Well-formedness properties of states *)

(** A state [mu, sigma, tau] is well-formed if the following properties hold:

- [mu] concatenated with [sigma] is a ``mill'', that is, no destination
  appears twice (predicate [is_mill] below).
- No temporary register appears in [mu] (predicate [move_no_temp]).
- No temporary register appears in [sigma] except perhaps as the source
  of the last move in [sigma] (predicate [temp_last]).
- [sigma] is a ``path'', that is, the source of a move is the destination
  of the following move.
*)

Definition is_mill (m: moves) : Prop :=
  list_norepet (dests m).

Definition is_not_temp (r: reg) : Prop :=
  forall d, r <> temp d.

Definition move_no_temp (m: moves) : Prop :=
  forall s d, In (s, d) m -> is_not_temp s /\ is_not_temp d.

Definition temp_last (m: moves) : Prop :=
  match List.rev m with
  | nil => True
  | (s, d) :: m' => is_not_temp d /\ move_no_temp m'
  end.

Definition is_first_dest (m: moves) (d: reg) : Prop :=
  match m with
  | nil => True
  | (s0, d0) :: _ => d = d0
  end.

Inductive is_path: moves -> Prop :=
  | is_path_nil:
      is_path nil
  | is_path_cons: forall s d m,
      is_first_dest m s ->
      is_path m ->
      is_path ((s, d) :: m).

Inductive state_wf: state -> Prop :=
  | state_wf_intro:
      forall mu sigma tau,
      is_mill (mu ++ sigma) ->
      move_no_temp mu ->
      temp_last sigma ->
      is_path sigma ->
      state_wf (State mu sigma tau).

(** Some trivial properties of srcs and dests. *)

Lemma dests_append:
  forall m1 m2, dests (m1 ++ m2) = dests m1 ++ dests m2.
Proof.
  intros. unfold dests. apply map_app.
Qed.

Lemma dests_decomp:
  forall m1 s d m2, dests (m1 ++ (s, d) :: m2) = dests m1 ++ d :: dests m2.
Proof.
  intros. unfold dests. rewrite map_app. reflexivity.
Qed.

Lemma srcs_append:
  forall m1 m2, srcs (m1 ++ m2) = srcs m1 ++ srcs m2.
Proof.
  intros. unfold srcs. apply map_app.
Qed.

Lemma srcs_decomp:
  forall m1 s d m2, srcs (m1 ++ (s, d) :: m2) = srcs m1 ++ s :: srcs m2.
Proof.
  intros. unfold srcs. rewrite map_app. reflexivity.
Qed.

Lemma srcs_dests_combine:
  forall s d,
  List.length s = List.length d ->
  srcs (List.combine s d) = s /\
  dests (List.combine s d) = d.
Proof.
  induction s; destruct d; simpl; intros.
  tauto.
  discriminate.
  discriminate.
  elim (IHs d); intros. split; congruence. congruence.
Qed.

(** Some properties of [is_mill] and [dests_disjoint]. *)

Definition dests_disjoint (m1 m2: moves) : Prop :=
  list_disjoint (dests m1) (dests m2).

Lemma dests_disjoint_sym:
  forall m1 m2,
  dests_disjoint m1 m2 <-> dests_disjoint m2 m1.
Proof.
  unfold dests_disjoint; intros.
  split; intros; apply list_disjoint_sym; auto.
Qed.

Lemma dests_disjoint_cons_left:
  forall m1 s d m2,
  dests_disjoint ((s, d) :: m1) m2 <->
  dests_disjoint m1 m2 /\ ~In d (dests m2).
Proof.
  unfold dests_disjoint, list_disjoint.
  simpl; intros; split; intros.
  split. auto. firstorder.
  destruct H. elim H0; intro.
  red; intro; subst. contradiction.
  apply H; auto.
Qed.

Lemma dests_disjoint_cons_right:
  forall m1 s d m2,
  dests_disjoint m1 ((s, d) :: m2) <->
  dests_disjoint m1 m2 /\ ~In d (dests m1).
Proof.
  intros. rewrite dests_disjoint_sym. rewrite dests_disjoint_cons_left.
  rewrite dests_disjoint_sym. tauto.
Qed.

Lemma dests_disjoint_append_left:
  forall m1 m2 m3,
  dests_disjoint (m1 ++ m2) m3 <->
  dests_disjoint m1 m3 /\ dests_disjoint m2 m3.
Proof.
  unfold dests_disjoint, list_disjoint.
  intros; split; intros. split; intros.
  apply H; eauto. rewrite dests_append. apply in_or_app. auto.
  apply H; eauto. rewrite dests_append. apply in_or_app. auto.
  destruct H.
  rewrite dests_append in H0. elim (in_app_or _ _ _ H0); auto.
Qed.

Lemma dests_disjoint_append_right:
  forall m1 m2 m3,
  dests_disjoint m1 (m2 ++ m3) <->
  dests_disjoint m1 m2 /\ dests_disjoint m1 m3.
Proof.
  intros. rewrite dests_disjoint_sym. rewrite dests_disjoint_append_left.
  intuition; rewrite dests_disjoint_sym; assumption.
Qed.

Lemma is_mill_cons:
  forall s d m,
  is_mill ((s, d) :: m) <->
  is_mill m /\ ~In d (dests m).
Proof.
  unfold is_mill, dests_disjoint; intros. simpl.
  split; intros.
  inversion H; tauto.
  constructor; tauto.
Qed.

Lemma is_mill_append:
  forall m1 m2,
  is_mill (m1 ++ m2) <->
  is_mill m1 /\ is_mill m2 /\ dests_disjoint m1 m2.
Proof.
  unfold is_mill, dests_disjoint; intros. rewrite dests_append.
  apply list_norepet_app.
Qed.

(** Some properties of [move_no_temp]. *)

Lemma move_no_temp_append:
  forall m1 m2,
  move_no_temp m1 -> move_no_temp m2 -> move_no_temp (m1 ++ m2).
Proof.
  intros; red; intros. elim (in_app_or _ _ _ H1); intro.
  apply H; auto. apply H0; auto.
Qed.

Lemma move_no_temp_rev:
  forall m, move_no_temp (List.rev m) -> move_no_temp m.
Proof.
  intros; red; intros. apply H. rewrite <- List.In_rev. auto.
Qed.

(** Some properties of [temp_last]. *)

Lemma temp_last_change_last_source:
  forall s d s' sigma,
  temp_last (sigma ++ (s, d) :: nil) ->
  temp_last (sigma ++ (s', d) :: nil).
Proof.
  intros until sigma. unfold temp_last.
  repeat rewrite rev_unit. auto.
Qed.

Lemma temp_last_push:
  forall s1 d1 s2 d2 sigma,
  temp_last ((s2, d2) :: sigma) ->
  is_not_temp s1 -> is_not_temp d1 ->
  temp_last ((s1, d1) :: (s2, d2) :: sigma).
Proof.
  unfold temp_last; intros. simpl. simpl in H.
  destruct (rev sigma); simpl in *.
  intuition. red; simpl; intros.
  elim H; intros. inversion H4. subst; tauto. tauto.
  destruct p as [sN dN]. intuition.
  red; intros. elim (in_app_or _ _ _ H); intros.
  apply H3; auto.
  elim H4; intros. inversion H5; subst; tauto. elim H5.
Qed.

Lemma temp_last_pop:
  forall s1 d1 sigma s2 d2,
  temp_last ((s1, d1) :: sigma ++ (s2, d2) :: nil) ->
  temp_last (sigma ++ (s2, d2) :: nil).
Proof.
  intros until d2.
  change ((s1, d1) :: sigma ++ (s2, d2) :: nil)
    with ((((s1, d1) :: nil) ++ sigma) ++ ((s2, d2) :: nil)).
  unfold temp_last. repeat rewrite rev_unit.
  intuition. simpl in H1. red; intros. apply H1.
  apply in_or_app. auto.
Qed.

(** Some properties of [is_path]. *)

Lemma is_path_pop:
  forall s d m,
  is_path ((s, d) :: m) -> is_path m.
Proof.
  intros. inversion H; subst. auto.
Qed.

Lemma is_path_change_last_source:
  forall s s' d sigma,
  is_path (sigma ++ (s, d) :: nil) ->
  is_path (sigma ++ (s', d) :: nil).
Proof.
  induction sigma; simpl; intros.
  constructor. red; auto. constructor.
  inversion H; subst; clear H.
  constructor.
  destruct sigma as [ | [s1 d1] sigma']; simpl; simpl in H2; auto.
  auto.
Qed.

Lemma path_sources_dests:
  forall s0 d0 sigma,
  is_path (sigma ++ (s0, d0) :: nil) ->
  List.incl (srcs (sigma ++ (s0, d0) :: nil))
            (s0 :: dests (sigma ++ (s0, d0) :: nil)).
Proof.
  induction sigma; simpl; intros.
  red; simpl; tauto.
  inversion H; subst; clear H. simpl.
  assert (In s (dests (sigma ++ (s0, d0) :: nil))).
    destruct sigma as [ | [s1 d1] sigma']; simpl; simpl in H2; intuition.
  apply incl_cons. simpl; tauto.
  apply incl_tran with (s0 :: dests (sigma ++ (s0, d0) :: nil)).
  eapply IHsigma; eauto.
  red; simpl; tauto.
Qed.

Lemma no_read_path:
  forall d1 sigma s0 d0,
  d1 <> s0 ->
  is_path (sigma ++ (s0, d0) :: nil) ->
  ~In d1 (dests (sigma ++ (s0, d0) :: nil)) ->
  no_read (sigma ++ (s0, d0) :: nil) d1.
Proof.
  intros.
  generalize (path_sources_dests _ _ _ H0). intro.
  intro. elim H1. elim (H2 _ H3); intro. congruence. auto.
Qed.

(** To benefit from some proof automation, we populate a rewrite database
  with some of the properties above. *)

Lemma notin_dests_cons:
  forall x s d m,
  ~In x (dests ((s, d) :: m)) <-> x <> d /\ ~In x (dests m).
Proof.
  intros. simpl. intuition auto.
Qed.

Lemma notin_dests_append:
  forall d m1 m2,
  ~In d (dests (m1 ++ m2)) <-> ~In d (dests m1) /\ ~In d (dests m2).
Proof.
  intros. rewrite dests_append. rewrite in_app. tauto.
Qed.

Hint Rewrite is_mill_cons is_mill_append
  dests_disjoint_cons_left dests_disjoint_cons_right
  dests_disjoint_append_left dests_disjoint_append_right
  notin_dests_cons notin_dests_append: pmov.

(** ** Transitions preserve well-formedness *)

Lemma transition_preserves_wf:
  forall st st',
  transition st st' -> state_wf st -> state_wf st'.
Proof.
  induction 1; intro WF; inversion WF as [mu0 sigma0 tau0 A B C D];
  subst;
  autorewrite with pmov in A; constructor; autorewrite with pmov.

  (* Nop *)
  tauto.
  red; intros. apply B. apply list_in_insert; auto.
  auto. auto.

  (* Start *)
  tauto.
  red; intros. apply B. apply list_in_insert; auto.
  red. simpl. split. elim (B s d). auto.
  apply in_or_app. right. apply in_eq.
  red; simpl; tauto.
  constructor. exact I. constructor.

  (* Push *)
  intuition.
  red; intros. apply B. apply list_in_insert; auto.
  elim (B d r). apply temp_last_push; auto.
  apply in_or_app; right; apply in_eq.
  constructor. simpl. auto. auto.

  (* Loop *)
  tauto.
  auto.
  eapply temp_last_change_last_source; eauto.
  eapply is_path_change_last_source; eauto.

  (* Pop *)
  intuition.
  auto.
  eapply temp_last_pop; eauto.
  eapply is_path_pop; eauto.

  (* Last *)
  intuition.
  auto.
  unfold temp_last. simpl. auto.
  constructor.
Qed.

Lemma transitions_preserve_wf:
  forall st st', transitions st st' -> state_wf st -> state_wf st'.
Proof.
  induction 1; intros; eauto.
  eapply transition_preserves_wf; eauto.
Qed.

(** ** Transitions preserve semantics *)

(** We define the semantics of states as follows.
  For a triple [mu, sigma, tau], we perform the moves [tau] in
  reverse sequential order, then the moves [mu ++ sigma] in parallel. *)

Definition statemove (st: state) (e: env) :=
  match st with
  | State mu sigma tau => exec_par (mu ++ sigma) (exec_seq_rev tau e)
  end.

(** In preparation to showing that transitions preserve semantics,
  we prove various properties of the parallel and sequential interpretations
  of moves. *)

Lemma exec_par_outside:
  forall m e r, ~In r (dests m) -> exec_par m e r = e r.
Proof.
  induction m; simpl; intros. auto.
  destruct a as [s d]. rewrite update_o. apply IHm. tauto.
  simpl in H. intuition.
Qed.

Lemma exec_par_lift:
  forall m1 s d m2 e,
  ~In d (dests m1) ->
  exec_par (m1 ++ (s, d) :: m2) e = exec_par ((s, d) :: m1 ++ m2) e.
Proof.
  induction m1; simpl; intros.
  auto.
  destruct a as [s0 d0]. simpl in H. rewrite IHm1. simpl.
  apply update_commut. tauto. tauto.
Qed.

Lemma exec_par_ident:
  forall m1 r m2 e,
  is_mill (m1 ++ (r, r) :: m2) ->
  exec_par (m1 ++ (r, r) :: m2) e = exec_par (m1 ++ m2) e.
Proof.
  intros. autorewrite with pmov in H.
  rewrite exec_par_lift. simpl.
  replace (e r) with (exec_par (m1 ++ m2) e r). apply update_ident.
  apply exec_par_outside. autorewrite with pmov. tauto. tauto.
Qed.

Lemma exec_seq_app:
  forall m1 m2 e,
  exec_seq (m1 ++ m2) e = exec_seq m2 (exec_seq m1 e).
Proof.
  induction m1; simpl; intros. auto.
  destruct a as [s d]. rewrite IHm1. auto.
Qed.

Lemma exec_seq_rev_app:
  forall m1 m2 e,
  exec_seq_rev (m1 ++ m2) e = exec_seq_rev m1 (exec_seq_rev m2 e).
Proof.
  induction m1; simpl; intros. auto.
  destruct a as [s d]. rewrite IHm1. auto.
Qed.

Lemma exec_seq_exec_seq_rev:
  forall m e,
  exec_seq_rev m e = exec_seq (List.rev m) e.
Proof.
  induction m; simpl; intros.
  auto.
  destruct a as [s d]. rewrite exec_seq_app. simpl. rewrite IHm. auto.
Qed.

Lemma exec_seq_rev_exec_seq:
  forall m e,
  exec_seq m e = exec_seq_rev (List.rev m) e.
Proof.
  intros. generalize (exec_seq_exec_seq_rev (List.rev m) e).
  rewrite List.rev_involutive. auto.
Qed.

Lemma exec_par_update_no_read:
  forall s d m e,
  no_read m d ->
  ~In d (dests m) ->
  exec_par m (update d (e s) e) =
  update d (e s) (exec_par m e).
Proof.
  unfold no_read; induction m; simpl; intros.
  auto.
  destruct a as [s0 d0]; simpl in *. rewrite IHm.
  rewrite update_commut. f_equal. f_equal.
  apply update_o. tauto. tauto. tauto. tauto.
Qed.

Lemma exec_par_append_eq:
  forall m1 m2 m3 e2 e3,
  exec_par m2 e2 = exec_par m3 e3 ->
  (forall r, In r (srcs m1) -> e2 r = e3 r) ->
  exec_par (m1 ++ m2) e2 = exec_par (m1 ++ m3) e3.
Proof.
  induction m1; simpl; intros.
  auto. destruct a as [s d]. f_equal; eauto.
Qed.

Lemma exec_par_combine:
  forall e sl dl,
  List.length sl = List.length dl ->
  list_norepet dl ->
  let e' := exec_par (combine sl dl) e in
  List.map e' dl = List.map e sl /\
  (forall l, ~In l dl -> e' l = e l).
Proof.
  induction sl; destruct dl; simpl; intros; try discriminate.
  split; auto.
  inversion H0; subst; clear H0.
  injection H; intro; clear H.
  destruct (IHsl dl H0 H4) as [A B].
  set (e' := exec_par (combine sl dl) e) in *.
  split.
  decEq. apply update_s.
  rewrite <- A. apply list_map_exten; intros.
  rewrite update_o. auto. congruence.
  intros. rewrite update_o. apply B. tauto. intuition.
Qed.

(** [env_equiv] is an equivalence relation between environments
  capturing the fact that two environments assign the same values to
  non-temporary registers, but can disagree on the values of temporary
  registers. *)

Definition env_equiv (e1 e2: env) : Prop :=
  forall r, is_not_temp r -> e1 r = e2 r.

Lemma env_equiv_refl:
  forall e, env_equiv e e.
Proof.
  unfold env_equiv; auto.
Qed.

Lemma env_equiv_refl':
  forall e1 e2, e1 = e2 -> env_equiv e1 e2.
Proof.
  unfold env_equiv; intros. rewrite H. auto.
Qed.

Lemma env_equiv_sym:
  forall e1 e2, env_equiv e1 e2 -> env_equiv e2 e1.
Proof.
  unfold env_equiv; intros. symmetry; auto.
Qed.

Lemma env_equiv_trans:
  forall e1 e2 e3, env_equiv e1 e2 -> env_equiv e2 e3 -> env_equiv e1 e3.
Proof.
  unfold env_equiv; intros. transitivity (e2 r); auto.
Qed.

Lemma exec_par_env_equiv:
  forall m e1 e2,
  move_no_temp m ->
  env_equiv e1 e2 ->
  env_equiv (exec_par m e1) (exec_par m e2).
Proof.
  unfold move_no_temp; induction m; simpl; intros.
  auto.
  destruct a as [s d].
  red; intros. unfold update. destruct (reg_eq r d).
  apply H0. elim (H s d); tauto.
  apply IHm; auto.
Qed.

(** The proof that transitions preserve semantics (up to the values of
  temporary registers) follows. *)

Lemma transition_preserves_semantics:
  forall st st' e,
  transition st st' -> state_wf st ->
  env_equiv (statemove st' e) (statemove st e).
Proof.
  induction 1; intro WF; inversion WF as [mu0 sigma0 tau0 A B C D]; subst; simpl.

  (* nop *)
  apply env_equiv_refl'. unfold statemove.
  repeat rewrite app_ass. simpl. symmetry. apply exec_par_ident.
  rewrite app_ass in A. exact A.

  (* start *)
  apply env_equiv_refl'. unfold statemove.
  autorewrite with pmov in A.
  rewrite exec_par_lift. repeat rewrite app_ass. simpl. rewrite exec_par_lift. reflexivity.
  tauto. autorewrite with pmov. tauto.

  (* push *)
  apply env_equiv_refl'. unfold statemove.
  autorewrite with pmov in A.
  rewrite exec_par_lift. rewrite exec_par_lift. simpl.
  rewrite exec_par_lift. repeat rewrite app_ass. simpl. rewrite exec_par_lift.
  simpl. apply update_commut. intuition.
  tauto. autorewrite with pmov; tauto.
  autorewrite with pmov; intuition.
  autorewrite with pmov; intuition.

  (* loop *)
  unfold statemove. simpl exec_seq_rev.
  set (e1 := exec_seq_rev tau e).
  autorewrite with pmov in A.
  repeat rewrite <- app_ass.
  assert (~In d (dests (mu ++ sigma))). autorewrite with pmov. tauto.
  repeat rewrite exec_par_lift; auto. simpl.
  repeat rewrite <- app_nil_end.
  assert (move_no_temp (mu ++ sigma)).
    red in C. rewrite rev_unit in C. destruct C.
    apply move_no_temp_append; auto. apply move_no_temp_rev; auto.
  set (e2 := update (temp s) (e1 s) e1).
  set (e3 := exec_par (mu ++ sigma) e1).
  set (e4 := exec_par (mu ++ sigma) e2).
  assert (env_equiv e2 e1).
    unfold e2; red; intros. apply update_o. apply H1.
  assert (env_equiv e4 e3).
    unfold e4, e3. apply exec_par_env_equiv; auto.
  red; intros. unfold update. destruct (reg_eq r d).
  unfold e2. apply update_s. apply H2. auto.

  (* pop *)
  apply env_equiv_refl'. unfold statemove. simpl exec_seq_rev.
  set (e1 := exec_seq_rev tau e).
  autorewrite with pmov in A.
  apply exec_par_append_eq. simpl.
  apply exec_par_update_no_read.
  apply no_read_path; auto. eapply is_path_pop; eauto.
  autorewrite with pmov; tauto.
  autorewrite with pmov; tauto.
  intros. apply update_o. red; intro; subst r. elim (H H1).

  (* last *)
  apply env_equiv_refl'. unfold statemove. simpl exec_seq_rev.
  set (e1 := exec_seq_rev tau e).
  apply exec_par_append_eq. simpl. auto.
  intros. apply update_o. red; intro; subst r. elim (H H0).
Qed.

Lemma transitions_preserve_semantics:
  forall st st' e,
  transitions st st' -> state_wf st ->
  env_equiv (statemove st' e) (statemove st e).
Proof.
  induction 1; intros.
  eapply transition_preserves_semantics; eauto.
  apply env_equiv_refl.
  apply env_equiv_trans with (statemove y e); auto.
  apply IHclos_refl_trans2. eapply transitions_preserve_wf; eauto.
Qed.

Lemma state_wf_start:
  forall mu,
  move_no_temp mu ->
  is_mill mu ->
  state_wf (State mu nil nil).
Proof.
  intros. constructor. rewrite <- app_nil_end. auto.
  auto.
  red. simpl. auto.
  constructor.
Qed.

(** The main correctness result in this section is the following:
  if we can transition repeatedly from an initial state [mu, nil, nil]
  to a final state [nil, nil, tau], then the sequential execution
  of the moves [rev tau] is semantically equivalent to the parallel
  execution of the moves [mu]. *)

Theorem transitions_correctness:
  forall mu tau,
  move_no_temp mu ->
  is_mill mu ->
  transitions (State mu nil nil) (State nil nil tau) ->
  forall e, env_equiv (exec_seq (List.rev tau) e) (exec_par mu e).
Proof.
  intros.
  generalize (transitions_preserve_semantics _ _ e H1
              (state_wf_start _ H H0)).
  unfold statemove. simpl. rewrite <- app_nil_end.
  rewrite exec_seq_exec_seq_rev. auto.
Qed.

(** * Determinisation of the transition relation *)

(** We now define a deterministic variant [dtransition] of the
  transition relation [transition].  [dtransition] is deterministic
  in the sense that at most one transition applies to a given state. *)

Inductive dtransition: state -> state -> Prop :=
  | dtr_nop: forall r mu tau,
      dtransition (State ((r, r) :: mu) nil tau)
                  (State mu nil tau)
  | dtr_start: forall s d mu tau,
      s <> d ->
      dtransition (State ((s, d) :: mu) nil tau)
                  (State mu ((s, d) :: nil) tau)
  | dtr_push: forall mu1 d r mu2 s sigma tau,
      no_read mu1 d ->
      dtransition (State (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau)
                  (State (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau)
  | dtr_loop_pop: forall mu s r0 d  sigma tau,
      no_read mu r0 ->
      dtransition (State mu ((s, r0) :: sigma ++ (r0, d) :: nil) tau)
                  (State mu (sigma ++ (temp r0, d) :: nil) ((s, r0) :: (r0, temp r0) :: tau))
  | dtr_pop: forall mu s0 d0 s1 d1 sigma tau,
      no_read mu d1 -> d1 <> s0 ->
      dtransition (State mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau)
                  (State mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau))
  | dtr_last: forall mu s d tau,
      no_read mu d ->
      dtransition (State mu ((s, d) :: nil) tau)
                  (State mu nil ((s, d) :: tau)).

Definition dtransitions: state -> state -> Prop :=
  clos_refl_trans state dtransition.

(** Every deterministic transition corresponds to a sequence of
  non-deterministic transitions. *)

Lemma transition_determ:
  forall st st',
  dtransition st st' ->
  state_wf st ->
  transitions st st'.
Proof.
  induction 1; intro; unfold transitions.
  apply rt_step. exact (tr_nop nil r mu nil tau).
  apply rt_step. exact (tr_start nil s d mu tau).
  apply rt_step. apply tr_push.
  eapply rt_trans.
    apply rt_step.
    change ((s, r0) :: sigma ++ (r0, d) :: nil)
      with (((s, r0) :: sigma) ++ (r0, d) :: nil).
    apply tr_loop.
    apply rt_step. simpl. apply tr_pop. auto.
    inv H0.  generalize H6.
    change ((s, r0) :: sigma ++ (r0, d) :: nil)
      with (((s, r0) :: sigma) ++ (r0, d) :: nil).
    unfold temp_last; rewrite List.rev_unit. intros [E F].
    elim (F s r0). unfold is_not_temp. auto.
    rewrite <- List.In_rev. apply in_eq.
  apply rt_step. apply tr_pop. auto. auto.
  apply rt_step. apply tr_last. auto.
Qed.

Lemma transitions_determ:
  forall st st',
  dtransitions st st' ->
  state_wf st ->
  transitions st st'.
Proof.
  unfold transitions; induction 1; intros.
  eapply transition_determ; eauto.
  apply rt_refl.
  apply rt_trans with y. auto.
    apply IHclos_refl_trans2.
    apply transitions_preserve_wf with x; auto. red; auto.
Qed.

(** The semantic correctness of deterministic transitions follows. *)

Theorem dtransitions_correctness:
  forall mu tau,
  move_no_temp mu ->
  is_mill mu ->
  dtransitions (State mu nil nil) (State nil nil tau) ->
  forall e, env_equiv (exec_seq (List.rev tau) e) (exec_par mu e).
Proof.
  intros.
  eapply transitions_correctness; eauto.
  apply transitions_determ. auto. apply state_wf_start; auto.
Qed.

(** * The compilation function *)

(** We now define a function that takes a well-formed parallel move [mu]
  and returns a sequence of elementary moves [tau] that is semantically
  equivalent.  We start by defining a number of auxiliary functions. *)

Function split_move (m: moves) (r: reg) {struct m} : option (moves * reg * moves) :=
  match m with
  | nil => None
  | (s, d) :: tl =>
      if reg_eq s r
      then Some (nil, d, tl)
      else match split_move tl r with
           | None => None
           | Some (before, d', after) => Some ((s, d) :: before, d', after)
           end
  end.

Function is_last_source (r: reg) (m: moves) {struct m} : bool :=
  match m with
  | nil => false
  | (s, d) :: nil =>
      if reg_eq s r then true else false
  | (s, d) :: tl =>
      is_last_source r tl
  end.

Function replace_last_source (r: reg) (m: moves) {struct m} : moves :=
  match m with
  | nil => nil
  | (s, d) :: nil => (r, d) :: nil
  | s_d :: tl => s_d :: replace_last_source r tl
  end.

Definition final_state (st: state) : bool :=
  match st with
  | State nil nil _ => true
  | _ => false
  end.

Definition parmove_step (st: state) : state :=
  match st with
  | State nil nil _ => st
  | State ((s, d) :: tl) nil l =>
      if reg_eq s d
      then State tl nil l
      else State tl ((s, d) :: nil) l
  | State t ((s, d) :: b) l =>
      match split_move t d with
      | Some (t1, r, t2) =>
          State (t1 ++ t2) ((d, r) :: (s, d) :: b) l
      | None =>
          match b with
          | nil => State t nil ((s, d) :: l)
          | _ =>
              if is_last_source d b
              then State t (replace_last_source (temp d) b) ((s, d) :: (d, temp d) :: l)
              else State t b ((s, d) :: l)
          end
      end
  end.

(** Here are the main correctness properties of these functions. *)

Lemma split_move_charact:
  forall m r,
  match split_move m r with
  | Some (before, d, after) => m = before ++ (r, d) :: after /\ no_read before r
  | None => no_read m r
  end.
Proof.
  unfold no_read. intros m r. functional induction (split_move m r).
  red; simpl. tauto.
  split. reflexivity. simpl; auto.
  rewrite e1 in IHo. simpl. intuition.
  rewrite e1 in IHo. destruct IHo. split. rewrite H. reflexivity.
  simpl. intuition.
Qed.

Lemma is_last_source_charact:
  forall r s d m,
  if is_last_source r (m ++ (s, d) :: nil)
  then s = r
  else s <> r.
Proof.
  induction m; simpl.
  destruct (reg_eq s r); congruence.
  destruct a as [s0 d0]. case_eq (m ++ (s, d) :: nil); intros.
  generalize (app_cons_not_nil m nil (s, d)). congruence.
  rewrite <- H. auto.
Qed.

Lemma replace_last_source_charact:
  forall s d s' m,
  replace_last_source s' (m ++ (s, d) :: nil) =
  m ++ (s', d) :: nil.
Proof.
  induction m; simpl.
  auto.
  destruct a as [s0 d0]. case_eq (m ++ (s, d) :: nil); intros.
  generalize (app_cons_not_nil m nil (s, d)). congruence.
  rewrite <- H. congruence.
Qed.

Lemma parmove_step_compatible:
  forall st,
  final_state st = false ->
  dtransition st (parmove_step st).
Proof.
  intros st NOTFINAL. destruct st as [mu sigma tau]. unfold parmove_step.
  case_eq mu; [intros MEQ | intros [ms md] mtl MEQ].
  case_eq sigma; [intros SEQ | intros [ss sd] stl SEQ].
  subst mu sigma. simpl in NOTFINAL. discriminate.
  simpl.
  case_eq stl; [intros STLEQ | intros xx1 xx2 STLEQ].
  apply dtr_last. red; simpl; auto.
  elim (@exists_last _ stl). 2:congruence. intros sigma1 [[ss1 sd1] SEQ2].
  rewrite <- STLEQ. clear STLEQ xx1 xx2.
  generalize (is_last_source_charact sd ss1 sd1 sigma1).
  rewrite SEQ2. destruct (is_last_source sd (sigma1 ++ (ss1, sd1) :: nil)).
  intro. subst ss1.
  rewrite replace_last_source_charact. apply dtr_loop_pop.
  red; simpl; auto.
  intro. apply dtr_pop. red; simpl; auto. auto.

  case_eq sigma; [intros SEQ | intros [ss sd] stl SEQ].
  destruct (reg_eq ms md).
  subst. apply dtr_nop.
  apply dtr_start. auto.

  generalize (split_move_charact ((ms, md) :: mtl) sd).
  case (split_move ((ms, md) :: mtl) sd); [intros [[before r] after] | idtac].
  intros [MEQ2 NOREAD].
  rewrite MEQ2. apply dtr_push. auto.
  intro NOREAD.
  case_eq stl; [intros STLEQ | intros xx1 xx2 STLEQ].
  apply dtr_last. auto.
  elim (@exists_last _ stl). 2:congruence. intros sigma1 [[ss1 sd1] SEQ2].
  rewrite <- STLEQ. clear STLEQ xx1 xx2.
  generalize (is_last_source_charact sd ss1 sd1 sigma1).
  rewrite SEQ2. destruct (is_last_source sd (sigma1 ++ (ss1, sd1) :: nil)).
  intro. subst ss1.
  rewrite replace_last_source_charact. apply dtr_loop_pop. auto.
  intro. apply dtr_pop. auto. auto.
Qed.

(** The compilation function is obtained by iterating the [parmov_step]
  function.  To show that this iteration always terminates, we introduce
  the following measure over states. *)

Open Scope nat_scope.

Definition measure (st: state) : nat :=
  match st with
  | State mu sigma tau => 2 * List.length mu + List.length sigma
  end.

Lemma measure_decreasing_1:
  forall st st',
  dtransition st st' -> measure st' < measure st.
Proof.
  induction 1; repeat (simpl; rewrite List.app_length); simpl; omega.
Qed.

Lemma measure_decreasing_2:
  forall st,
  final_state st = false ->
  measure (parmove_step st) < measure st.
Proof.
  intros. apply measure_decreasing_1. apply parmove_step_compatible; auto.
Qed.

(** Compilation function for parallel moves. *)

Function parmove_aux (st: state) {measure measure st} : moves :=
  if final_state st
  then match st with State _ _ tau => tau end
  else parmove_aux (parmove_step st).
Proof.
  intros. apply measure_decreasing_2. auto.
Qed.

Lemma parmove_aux_transitions:
  forall st,
  dtransitions st (State nil nil (parmove_aux st)).
Proof.
  unfold dtransitions. intro st. functional induction (parmove_aux st).
  destruct _x; destruct _x0; simpl in e; discriminate || apply rt_refl.
  eapply rt_trans. apply rt_step. apply parmove_step_compatible; eauto.
  auto.
Qed.

Definition parmove (mu: moves) : moves :=
  List.rev (parmove_aux (State mu nil nil)).

(** This is the main correctness theorem: the sequence of elementary
  moves [parmove mu] is semantically equivalent to the parallel move
  [mu] if the latter is well-formed. *)

Theorem parmove_correctness:
  forall mu,
  move_no_temp mu -> is_mill mu ->
  forall e,
  env_equiv (exec_seq (parmove mu) e) (exec_par mu e).
Proof.
  intros. unfold parmove. apply dtransitions_correctness; auto.
  apply parmove_aux_transitions.
Qed.

(** Here is an alternate formulation of [parmove], where the
  parallel move problem is given as two separate lists of sources
  and destinations. *)

Definition parmove2 (sl dl: list reg) : moves :=
  parmove (List.combine sl dl).

Theorem parmove2_correctness:
  forall sl dl,
  List.length sl = List.length dl ->
  list_norepet dl ->
  (forall r, In r sl -> is_not_temp r) ->
  (forall r, In r dl -> is_not_temp r) ->
  forall e,
  let e' := exec_seq (parmove2 sl dl) e in
  List.map e' dl = List.map e sl /\
  forall r, ~In r dl -> is_not_temp r -> e' r = e r.
Proof.
  intros.
  destruct (srcs_dests_combine sl dl H) as [A B].
  assert (env_equiv e' (exec_par (List.combine sl dl) e)).
    unfold e', parmove2. apply parmove_correctness.
    red; intros; split.
    apply H1. eapply List.in_combine_l; eauto.
    apply H2. eapply List.in_combine_r; eauto.
    red. rewrite B. auto.
  destruct (exec_par_combine e sl dl H H0) as [C D].
  set (e1 := exec_par (combine sl dl) e) in *.
  split. rewrite <- C. apply list_map_exten; intros.
  symmetry. apply H3. auto.
  intros. transitivity (e1 r); auto.
Qed.

(** * Additional syntactic properties *)

(** We now show an additional property of the sequence of moves
  generated by [parmove mu]: any such move [s -> d] is either
  already present in [mu], or of the form [temp s -> d] or [s -> temp s]
  for some [s -> d] in [mu].  This syntactic property is useful
  to show that [parmove] preserves register classes, for instance. *)

Section PROPERTIES.

Variable initial_move: moves.

Inductive wf_move: reg -> reg -> Prop :=
  | wf_move_same: forall s d,
      In (s, d) initial_move -> wf_move s d
  | wf_move_temp_left: forall s d,
      wf_move s d -> wf_move (temp s) d
  | wf_move_temp_right: forall s d,
      wf_move s d -> wf_move s (temp s).

Definition wf_moves (m: moves) : Prop :=
  forall s d, In (s, d) m -> wf_move s d.

Lemma wf_moves_cons: forall s d m,
  wf_moves ((s, d) :: m) <-> wf_move s d /\ wf_moves m.
Proof.
  unfold wf_moves; intros; simpl. firstorder.
  inversion H0; subst s0 d0. auto.
Qed.

Lemma wf_moves_append: forall m1 m2,
  wf_moves (m1 ++ m2) <-> wf_moves m1 /\ wf_moves m2.
Proof.
  unfold wf_moves; intros. split; intros.
  split; intros; apply H; apply in_or_app; auto.
  destruct H. elim (in_app_or _ _ _ H0); intro; auto.
Qed.

Hint Rewrite wf_moves_cons wf_moves_append: pmov.

Inductive wf_state: state -> Prop :=
  | wf_state_intro: forall mu sigma tau,
      wf_moves mu -> wf_moves sigma -> wf_moves tau ->
      wf_state (State mu sigma tau).

Lemma dtransition_preserves_wf_state:
  forall st st',
  dtransition st st' -> wf_state st -> wf_state st'.
Proof.
  induction 1; intro WF; inv WF; constructor; autorewrite with pmov in *; intuition.
  apply wf_move_temp_left; auto.
  eapply wf_move_temp_right; eauto.
Qed.

Lemma dtransitions_preserve_wf_state:
  forall st st',
  dtransitions st st' -> wf_state st -> wf_state st'.
Proof.
  induction 1; intros; eauto.
  eapply dtransition_preserves_wf_state; eauto.
Qed.

End PROPERTIES.

Lemma parmove_wf_moves:
  forall mu, wf_moves mu (parmove mu).
Proof.
  intros.
  assert (wf_state mu (State mu nil nil)).
    constructor. red; intros. apply wf_move_same. auto.
    red; simpl; tauto. red; simpl; tauto.
  generalize (dtransitions_preserve_wf_state mu
              _ _
              (parmove_aux_transitions (State mu nil nil)) H).
  intro WFS. inv WFS.
  unfold parmove. red; intros. apply H5.
  rewrite List.In_rev. auto.
Qed.

Lemma parmove2_wf_moves:
  forall sl dl, wf_moves (List.combine sl dl) (parmove2 sl dl).
Proof.
  intros. unfold parmove2. apply parmove_wf_moves.
Qed.

(** As a corollary, we show that all sources of [parmove mu]
    are sources of [mu] or temporaries,
    and likewise all destinations of [parmove mu] are destinations of [mu]
    or temporaries. *)

Remark wf_move_initial_reg_or_temp:
  forall mu s d,
  wf_move mu s d ->
  (In s (srcs mu) \/ is_temp s) /\ (In d (dests mu) \/ is_temp d).
Proof.
  induction 1.
  split; left.
  change s with (fst (s, d)). unfold srcs. apply List.in_map; auto.
  change d with (snd (s, d)). unfold dests. apply List.in_map; auto.
  split. right. exists s; auto. tauto.
  split. tauto. right. exists s; auto.
Qed.

Lemma parmove_initial_reg_or_temp:
  forall mu s d,
  In (s, d) (parmove mu) ->
  (In s (srcs mu) \/ is_temp s) /\ (In d (dests mu) \/ is_temp d).
Proof.
  intros. apply wf_move_initial_reg_or_temp. apply parmove_wf_moves. auto.
Qed.

Remark in_srcs:
  forall mu s, In s (srcs mu) -> exists d, In (s, d) mu.
Proof.
  intros. destruct (list_in_map_inv (@fst reg reg) _ _ H) as [[s' d'] [A B]].
  simpl in A. exists d'; congruence.
Qed.

Remark in_dests:
  forall mu d, In d (dests mu) -> exists s, In (s, d) mu.
Proof.
  intros. destruct (list_in_map_inv (@snd reg reg) _ _ H) as [[s' d'] [A B]].
  simpl in A. exists s'; congruence.
Qed.

Lemma parmove_srcs_initial_reg_or_temp:
  forall mu s,
  In s (srcs (parmove mu)) -> In s (srcs mu) \/ is_temp s.
Proof.
  intros. destruct (in_srcs _ _ H) as [d A].
  destruct (parmove_initial_reg_or_temp _ _ _ A). auto.
Qed.

Lemma parmove_dests_initial_reg_or_temp:
  forall mu d,
  In d (dests (parmove mu)) -> In d (dests mu) \/ is_temp d.
Proof.
  intros. destruct (in_dests _ _ H) as [s A].
  destruct (parmove_initial_reg_or_temp _ _ _ A). auto.
Qed.

(** As a second corollary, we show that [parmov] preserves register
    classes, in the sense made precise below. *)

Section REGISTER_CLASSES.

Variable class: Type.
Variable regclass: reg -> class.
Hypothesis temp_preserves_class: forall r, regclass (temp r) = regclass r.

Definition is_class_compatible (mu: moves) : Prop :=
  forall s d, In (s, d) mu -> regclass s = regclass d.

Lemma parmove_preserves_register_classes:
  forall mu,
  is_class_compatible mu ->
  is_class_compatible (parmove mu).
Proof.
  intros.
  assert (forall s d, wf_move mu s d -> regclass s = regclass d).
    induction 1.
    apply H; auto.
    rewrite temp_preserves_class. auto.
    symmetry; apply temp_preserves_class.
  red; intros. apply H0. apply parmove_wf_moves. auto.
Qed.

End REGISTER_CLASSES.

(** * Extension to partially overlapping registers *)

(** We now extend the previous results to the case where distinct
  registers can partially overlap, so that assigning to one register
  changes the value of the other.  We asuume given a disjointness relation
  [disjoint] between registers. *)

Variable disjoint: reg -> reg -> Prop.

Hypothesis disjoint_sym:
  forall r1 r2, disjoint r1 r2 -> disjoint r2 r1.

Hypothesis disjoint_not_equal:
  forall r1 r2, disjoint r1 r2 -> r1 <> r2.

(** Two registers partially overlap if they are different and not disjoint.
    For the Coq development, it is easier to define the complement:
    two registers do not partially overlap if they are identical or disjoint. *)

Definition no_overlap (r1 r2: reg) : Prop :=
  r1 = r2 \/ disjoint r1 r2.

Lemma no_overlap_sym:
  forall r1 r2, no_overlap r1 r2 -> no_overlap r2 r1.
Proof.
  intros. destruct H. left; auto. right; auto.
Qed.

(** We axiomatize the effect of assigning a value to a register over an
  execution environment.  The target register is set to the given value
  (property [weak_update_s]), and registers disjoint from the target
  keep their previous values (property [weak_update_d]).  The values of
  other registers are undefined after the assignment. *)

Variable weak_update: reg -> val -> env -> env.

Hypothesis weak_update_s:
  forall r v e, weak_update r v e r = v.

Hypothesis weak_update_d:
  forall r1 v e r2, disjoint r1 r2 -> weak_update r1 v e r2 = e r2.

Fixpoint weak_exec_seq (m: moves) (e: env) {struct m}: env :=
  match m with
  | nil => e
  | (s, d) :: m' => weak_exec_seq m' (weak_update d (e s) e)
  end.

Definition disjoint_list (r: reg) (l: list reg) : Prop :=
  forall r', In r' l -> disjoint r r'.

Inductive pairwise_disjoint: list reg -> Prop :=
  | pairwise_disjoint_nil:
      pairwise_disjoint nil
  | pairwise_disjoint_cons: forall r l,
      disjoint_list r l ->
      pairwise_disjoint l ->
      pairwise_disjoint (r :: l).

Definition disjoint_temps (r: reg) : Prop :=
  forall t, is_temp t -> disjoint r t.

Section OVERLAP.

(** We consider a parallel move problem [mu] that satisfies the following
  conditions, which are stronger, overlap-aware variants of the
  [move_no_temp mu] and [is_mill mu] conditions used previously. *)

Variable mu: moves.

(** Sources and destinations are disjoint from all temporary registers. *)

Hypothesis mu_no_temporaries_src:
  forall s, In s (srcs mu) -> disjoint_temps s.

Hypothesis mu_no_temporaries_dst:
  forall d, In d (dests mu) -> disjoint_temps d.

(** Destinations are pairwise disjoint. *)

Hypothesis mu_dest_pairwise_disjoint:
  pairwise_disjoint (dests mu).

(** Sources and destinations do not partially overlap. *)

Hypothesis mu_src_dst_no_overlap:
  forall s d, In s (srcs mu) -> In d (dests mu) -> no_overlap s d.

(** Distinct temporaries do not partially overlap. *)

Hypothesis temps_no_overlap:
  forall t1 t2, is_temp t1 -> is_temp t2 -> no_overlap t1 t2.

(** The following lemmas show that [mu] is a windmill and does not
  contain temporary registers. *)

Lemma disjoint_list_notin:
  forall r l, disjoint_list r l -> ~In r l.
Proof.
  intros. red; intro.
  assert (r <> r). apply disjoint_not_equal. apply H; auto.
  congruence.
Qed.

Lemma pairwise_disjoint_norepet:
  forall l, pairwise_disjoint l -> list_norepet l.
Proof.
  induction 1.
  constructor.
  constructor. apply disjoint_list_notin; auto. auto.
Qed.

Lemma disjoint_temps_not_temp:
  forall r, disjoint_temps r -> is_not_temp r.
Proof.
  intros; red; intros. apply disjoint_not_equal. apply H. exists d; auto.
Qed.

Lemma mu_is_mill:
  is_mill mu.
Proof.
  red. apply pairwise_disjoint_norepet. auto.
Qed.

Lemma mu_move_no_temp:
  move_no_temp mu.
Proof.
  red; intros.
  split; apply disjoint_temps_not_temp.
  apply mu_no_temporaries_src; auto.
  unfold srcs. change s with (fst (s,d)). apply List.in_map; auto.
  apply mu_no_temporaries_dst; auto.
  unfold dests. change d with (snd (s,d)). apply List.in_map; auto.
Qed.

(** We define the ``adherence'' of the problem [mu] as the set of
  registers that partially overlap with one of the registers
  possibly assigned by the parallel move: destinations and temporaries.
  Again, we define the complement of the ``adherence'' set, which is
  more convenient for Coq reasoning. *)

Definition no_adherence (r: reg) : Prop :=
  forall x, In x (dests mu) \/ is_temp x -> no_overlap x r.

(** As a consequence of the hypotheses on [mu], none of the destination
  registers, source registers, and temporaries belong to the adherence. *)

Lemma no_overlap_pairwise:
  forall r1 r2 m, pairwise_disjoint m -> In r1 m -> In r2 m -> no_overlap r1 r2.
Proof.
  induction 1; intros.
  elim H.
  simpl in *. destruct H1; destruct H2.
  left. congruence.
  subst. right. apply H. auto.
  subst. right. apply disjoint_sym. apply H. auto.
  auto.
Qed.

Lemma no_adherence_dst:
  forall d, In d (dests mu) -> no_adherence d.
Proof.
  intros; red; intros.
  destruct H0. apply no_overlap_pairwise with (dests mu); auto.
  right. apply disjoint_sym. apply mu_no_temporaries_dst; auto.
Qed.

Lemma no_adherence_src:
  forall s, In s (srcs mu) -> no_adherence s.
Proof.
  intros; red; intros.
  destruct H0.
  apply no_overlap_sym. apply mu_src_dst_no_overlap; auto.
  right. apply disjoint_sym. apply mu_no_temporaries_src; auto.
Qed.

Lemma no_adherence_tmp:
  forall t, is_temp t -> no_adherence t.
Proof.
  intros; red; intros.
  destruct H0.
  right. apply mu_no_temporaries_dst; auto.
  apply temps_no_overlap; auto.
Qed.

(** The relation [env_match] holds between two environments [e1] and [e2]
    if they assign the same values to all registers not in the adherence set. *)

Definition env_match (e1 e2: env) : Prop :=
  forall r, no_adherence r -> e1 r = e2 r.

(** The following lemmas relate the effect of executing moves
  using normal, overlap-unaware update and weak, overlap-aware update. *)

Lemma weak_update_match:
  forall e1 e2 s d,
  (In s (srcs mu) \/ is_temp s) ->
  (In d (dests mu) \/ is_temp d) ->
  env_match e1 e2 ->
  env_match (update d (e1 s) e1)
            (weak_update d (e2 s) e2).
Proof.
  intros. red; intros.
  assert (no_overlap d r). apply H2. auto.
  destruct H3.
  subst. rewrite update_s. rewrite weak_update_s. apply H1.
  destruct H. apply no_adherence_src; auto. apply no_adherence_tmp; auto.
  rewrite update_o. rewrite weak_update_d. apply H1. auto.
  auto. apply sym_not_equal. apply disjoint_not_equal. auto.
Qed.

Lemma weak_exec_seq_match:
  forall m e1 e2,
  (forall s, In s (srcs m) -> In s (srcs mu) \/ is_temp s) ->
  (forall d, In d (dests m) -> In d (dests mu) \/ is_temp d) ->
  env_match e1 e2 ->
  env_match (exec_seq m e1) (weak_exec_seq m e2).
Proof.
  induction m; intros; simpl.
  auto.
  destruct a as [s d]. simpl in H. simpl in H0.
  apply IHm; auto.
  apply weak_update_match; auto.
Qed.

End OVERLAP.

(** These lemmas imply the following correctness theorem for the [parmove2]
  function, taking partial register overlap into account. *)

Theorem parmove2_correctness_with_overlap:
  forall sl dl,
  List.length sl = List.length dl ->
  (forall r, In r sl -> disjoint_temps r) ->
  (forall r, In r dl -> disjoint_temps r) ->
  pairwise_disjoint dl ->
  (forall s d, In s sl -> In d dl -> no_overlap s d) ->
  (forall t1 t2, is_temp t1 -> is_temp t2 -> no_overlap t1 t2) ->
  forall e,
  let e' := weak_exec_seq (parmove2 sl dl) e in
  List.map e' dl = List.map e sl /\
  forall r, disjoint_list r dl -> disjoint_temps r -> e' r = e r.
Proof.
  intros.
  assert (list_norepet dl).
    apply pairwise_disjoint_norepet; auto.
  assert (forall r : reg, In r sl -> is_not_temp r).
    intros. apply disjoint_temps_not_temp; auto.
  assert (forall r : reg, In r dl -> is_not_temp r).
    intros. apply disjoint_temps_not_temp; auto.
  generalize (parmove2_correctness sl dl H H5 H6 H7 e).
  set (e1 := exec_seq (parmove2 sl dl) e). intros [A B].
  destruct (srcs_dests_combine sl dl H) as [C D].
  assert (env_match (combine sl dl) e1 e').
    unfold parmove2. unfold e1, e'.
    apply weak_exec_seq_match; try (rewrite C); try (rewrite D); auto.
    intros. rewrite <- C. apply parmove_srcs_initial_reg_or_temp. auto.
    intros. rewrite <- D. apply parmove_dests_initial_reg_or_temp. auto.
    red; auto.
  split.
  rewrite <- A.
  apply list_map_exten; intros. apply H8.
  apply no_adherence_dst. rewrite D; auto. rewrite D; auto. rewrite D; auto.
  intros. transitivity (e1 r).
  symmetry. apply H8. red. rewrite D. intros. destruct H11.
  right. apply disjoint_sym. apply H9. auto.
  right. apply disjoint_sym. apply H10. auto.
  apply B. apply disjoint_list_notin; auto. apply disjoint_temps_not_temp; auto.
Qed.

End PARMOV.


From Undecidability Require Import TM.Util.Prelim.
From Undecidability Require Import TM.Util.TM_facts TM.Compound.MoveToSymbol.

Require Import ssrbool Lia.
Lemma last_not_default X (d d':X) A :
  A <> [] -> last A d = last A d'.
Proof. induction A. easy. destruct A;cbn. easy. intros ?. now apply IHA. Qed.

Lemma removelast_as_tail X (x:list X): removelast x = rev (tail (rev x)).
Proof.
  rewrite tl_rev. symmetry. apply rev_involutive.
Qed.

Local Arguments removelast : simpl nomatch.
Local Arguments last : simpl nomatch.

(** TIPP: Look in ./Copy.v **)
(** I have no Idea anymore why i called this nicer ... *)

Definition MoveToSymbol_Rel_nice (sig':finType) (f:sig' -> bool) (g:sig' -> sig') t t' :=
  ((current t = None /\ t = t')
   \/ (exists t__L c t__R1 t__R2,
         t = midtape t__L c (t__R1++t__R2)
         /\ (forall x, x el (removelast (c::t__R1)) -> f x = false)
         /\ f (last (c::t__R1) c) = ssrbool.isSome (current t')
         /\ (t' = midtape (rev (map g (removelast (c::t__R1)))++t__L) (g (last (c::t__R1) c)) t__R2
            \/ (t' = rightof (g (last (c::t__R1) c)) (rev (map g (removelast (c::t__R1)))++t__L) /\ t__R2 = [])))).

Lemma MoveToSymbol_Fun_nice (sig':finType) (f:sig' -> bool) (g:sig' -> sig') t t' :
  MoveToSymbol_Fun f g t = t' <-> MoveToSymbol_Rel_nice f g t t'.
Proof.
  remember (tape_local t) as A eqn:eqA.
  revert t t' eqA. unfold MoveToSymbol_Rel_nice.
  induction A using (size_induction (f:=@length sig'));intros t t' eqA.
  rewrite MoveToSymbol_Fun_equation. destruct current eqn:eq.
  2:{ split. now left. intros [ | H']. easy. destruct H' as (?&?&?&?&->&?). easy. }
  destruct f eqn:Hf.
  { destruct t;inv eq. all:cbn. split.
    -intros <-. right. eexists _,_,[],_.
     repeat split;eauto.
     intros x Hx. destruct Hx.
    -intros [ | (t__L&c&t__R1&t__R2&[= -> -> -> ]&Hfalse&Hc&H'')];[ easy | ].
     destruct t__R1 as [ | c__R t__R1].
     2:{exfalso. cbn in *. rewrite Hfalse in Hf;auto. }
     cbn in *.
     destruct H'' as [-> | [-> -> ]]. all:cbn in *;now eauto + congruence.
  }
  destruct t. all:inv eq. destruct l0. all:cbn - [removelast].
  all:rewrite H;[ | | reflexivity];[cbn | cbn;nia].
  - cbn. split.
    +intros [(_&<-)| (?&?&?&?&[=]&?)];[]. right.
     eexists _,_,[],[]. split;[reflexivity| ]. split;[easy| ]. unfold last, removelast;cbn. eauto.
    +intros [([=]&?)|(t__L&c&t__R1&t__R2&[= <- <- H__nil]&Hfalse&Hc&H'')];[].
     destruct t__R1;[ |now inv H__nil]. destruct t__R2;[ |now inv H__nil]. clear H__nil.
     cbn in H''|-*. destruct H'' as [-> | [-> _ ]]. 2:now left. now unfold last in Hc;cbn in Hc;congruence.
  -eapply Morphisms_Prop.or_iff_morphism. easy.
   split. all:intros (t__L&c&t__R1&t__R2&Heq&Hfalse&Hc&H');revert Heq.
   +intros [= <- -> ->]. eexists _,_,(_::_),_. split. reflexivity.
    cbn. split. now intros ? [-> | ];eauto.
    autorewrite with list in |-*;cbn. erewrite last_not_default. split;now eauto. easy.
   +intros [= -> -> Heq]. destruct t__R1.
    {cbn in *. destruct H' as [ -> | [-> ->]]. all: now cbn in *;congruence. }
    revert Heq;intros [= -> ->].
    eexists (_::_),_,_,_. split. reflexivity. cbn in *.
    split. now eauto. autorewrite with list in H';cbn. erewrite last_not_default. 2:easy. split;now eauto.
Qed.

Lemma MoveToSymbol_Fun_is_rel (sig':finType) (f:sig' -> bool) (g:sig' -> sig') t :
  MoveToSymbol_Rel_nice f g t (MoveToSymbol_Fun f g t).
Proof.
  now rewrite <- MoveToSymbol_Fun_nice.
Qed.


Require Import List.
Require Import Arith.

(** * VM for "Virtual Machine" *)

Require Import CU.
Require Import FB.
Require Import Common.

Inductive code_pointer : Set :=
| CP_user : nat -> code_pointer
| CP_pap : nat -> code_pointer
| CP_cons : constructor -> nat -> code_pointer.

Definition eq_cp_dec : forall c d : code_pointer, {c = d} + {c <> d}.
Proof.
repeat decide equality.
Defined.

Inductive expr : Set :=
| App : var -> vars -> CU.cleanup -> expr
| Constr : constructor -> vars -> CU.cleanup -> expr
| Letrec : list (vars * code_pointer) -> expr -> expr
| Case : expr -> code_pointer -> expr.

Definition lambda_form := gen_lambda_form (Expr := expr).

Definition alt := gen_alt (Expr := code_pointer).

Definition alts := list alt.

Inductive cs_node : Set :=
| CS_expr : expr -> cs_node
| CS_alts : alts -> cs_node
| CS_lf : lambda_form -> cs_node
| CS_None.

Definition code_store := list (code_pointer * cs_node).

Fixpoint find_cs (cs : code_store) (cp : code_pointer) : cs_node :=
match cs with
| nil => CS_None
| (cp0, node) :: cs0 => if eq_cp_dec cp cp0
  then node
  else find_cs cs0 cp
end.

Definition closure := (code_pointer * addresses)%type.

Definition closures := list closure.

Definition heap := address -> option closure.

Inductive config : Set :=
| Config : heap -> expr -> env -> (argstack * FB.fake_bottom)
  -> address -> config
| Enter : heap -> address -> argstack * FB.fake_bottom -> env -> config.

Inductive ret_value : Set :=
| Val_con : heap -> constructor -> addresses -> ret_value
| Val_pap : heap -> address -> addresses -> ret_value.

Definition value := (ret_value * env * (argstack * FB.fake_bottom))%type.

Notation " << a , b , c , d , e >> " := (Config a b c d e) (at level 70).
Notation " << a , b , c , d >> " := (Enter a b c d) (at level 70).

Inductive action : Set :=
| E : config -> action
| A : value -> action.

Inductive stack_elem : Set :=
| K_alt : code_pointer -> FB.fake_bottom -> stack_elem
| K_upd : address -> FB.fake_bottom -> stack_elem.

Definition stack := list stack_elem.

Definition look_up (e : env) (g : heap) (p : address) (v : var)
  : option address :=
match v with
| B_ind n => nth n e
| C_ind n => match g p with Some (_, clo) => nth n clo | None => None end
end.

Fixpoint map_env (e : env) (g : heap) (a : address) (vs : vars) {struct vs}
  : option addresses :=
match vs with
| nil => Some nil
| x::xs =>
  match map_env e g a xs with
  | Some ps =>
    match look_up e g a x with
    | Some p => Some (p::ps)
    | None => None
    end
  | None => None
  end
end.

Definition set (g : heap) (a : address) (clo : closure) : gen_heap :=
fun (x : address) => if eq_nat_dec x a
  then Some clo
  else g x.

Definition alloc (g : heap) (addrs : addresses) (clos : list closure)
  : heap :=
fold_right (fun (ad : address * closure) (h : gen_heap) =>
  set h (fst ad) (snd ad))
  g (combine addrs clos).

Lemma set_eq :
forall H s v,
  set H s v s = Some v.
Proof with isa.
intros.
unfold set.
destruct (eq_nat_dec)...
tauto.
Qed.

Lemma set_neq :
forall H s v p
  (NEQ : p <> s),
  set H p v s = H s.
Proof with isa.
intros.
unfold set.
destruct eq_nat_dec...
symmetry in e.
intuition.
Qed.

Lemma alloc_in :
forall H vs v lfs lf
  (LEN   : length vs = length lfs)
  (IN    : In v vs)
  (ALLOC : alloc H vs lfs v = Some lf),
  In lf lfs.
Proof with isa.
induction vs...
contradiction.
destruct lfs; try discriminate...
inversion LEN as [ LEN0 ].
destruct (eq_nat_dec a v).
(* eq *)
subst...
unfold alloc in *...
rewrite set_eq in ALLOC.
inversion ALLOC as [ ALLOC0 ]; subst; auto.
(* neq *)
unfold alloc in *...
rewrite set_neq in ALLOC...
right; eapply IHvs; eauto.
fold (alloc H vs lfs) in ALLOC.
inversion IN...
contradiction.
Qed.

Lemma alloc_nin :
forall H vs p
  (NIN : ~ In p vs)
  lfs,
  alloc H vs lfs p = H p.
Proof with isa.
induction vs.
trivial.
assert (NOTIN : forall A p (x : A) xs,
  ~ In p (x :: xs) -> p <> x /\ ~ In p xs).
  isa.
intros.
apply NOTIN in NIN.
destruct NIN as [ NEQ NIN ].
destruct lfs...
unfold alloc...
rewrite set_neq...
fold (alloc H vs lfs)...
Qed.

Lemma alloc_some :
forall H a ats lfs
  (LEN : length ats = length lfs)
  (IN  : In a ats),
  exists r, alloc H ats lfs a = Some r.
Proof with isa.
induction ats...
contradiction.
unfold alloc in *.
destruct lfs; simpl in *; try discriminate.
unfold set in *.
destruct (eq_nat_dec a a0); subst.
(* eq *)
exists c...
(* neq *)
apply IHats.
inversion LEN...
destruct IN...
destruct n...
Qed.

Definition make_closure (e : env) (g : heap) (p : address)
  (cpvs : vars * code_pointer) : option closure :=
match cpvs with
| (vs, cp) =>
  match map_env e g p vs with
  | Some addrs => Some (cp, addrs)
  | None => None
  end
end.

Fixpoint make_closures (e : env) (g : heap) (p : address)
  (cps : list (vars * code_pointer)) {struct cps} : option closures:=
match cps with
| nil => Some nil
| cp::cps0 =>
  match make_closures e g p cps0 with
  | Some clos =>
    match make_closure e g p cp with
    | Some clo => Some (clo::clos)
    | None => None
    end
  | None => None
  end
end.

Reserved Notation " cs @@ a ^\ b " (at level 70, no associativity).

Inductive Sem (cs : code_store) : (action * stack) -> value -> Prop :=

| Halt : forall Value,
  cs @@ (A Value, nil) ^\ Value

| Cons : forall Gamma C xs sigma addrs cleanup args fake_bot pclo Value K
  (MAPENV  : map_env sigma Gamma pclo xs = Some addrs)
  (ARGSNIL : fake_bot = length args)
  (PREMISE : cs @@ (A (Val_con Gamma C addrs, (skipn cleanup sigma), (args, fake_bot)), K) ^\ Value),
  cs @@ (E (<< Gamma, Constr C xs (cleanup), sigma, (args, fake_bot), pclo >>), K) ^\ Value

| Accum : forall Gamma x xs sigma args p new_args Value cleanup fake_bot pclo K
  (MAPENV  : map_env sigma Gamma pclo xs = Some new_args)
  (LOOKUP  : look_up sigma Gamma pclo x = Some p)
  (PREMISE : cs @@ (E (<< Gamma, p, (new_args++args, fake_bot), skipn cleanup sigma >>), K) ^\ Value),
  cs @@ (E (<< Gamma, App x xs (cleanup), sigma, (args, fake_bot), pclo >>), K) ^\ Value

| App1 : forall cp Gamma p args clovars bind e some_clo sigma fake_bot real_args fake_args Value K
  (CS      : find_cs cs cp = CS_lf (Lf Dont_update clovars bind e))
  (ONHEAP  : Gamma p = Some (cp, some_clo))
  (REAL    : real_args = firstn (length args - fake_bot) args)
  (FAKE    : fake_args = skipn (length args - fake_bot) args)
  (LENGTH  : bind > length args - fake_bot)
  (PREMISE : cs @@ (A (Val_pap Gamma p real_args, sigma, (fake_args, fake_bot)), K) ^\ Value),
  cs @@ (E (<< Gamma, p, (args, fake_bot), sigma >>), K) ^\ Value

| App2 : forall cp Gamma p args Value e bind clo clovars sigma fake_bot K
  (CS      : find_cs cs cp = CS_lf (Lf Dont_update clovars bind e))
  (ONHEAP  : Gamma p = Some (cp, clo))
  (LENGTH  : bind <= length args - fake_bot)
  (PREMISE : cs @@ (E (<< Gamma, e, firstn bind args ++ sigma, (skipn bind args, fake_bot), p >>), K) ^\ Value),
  cs @@ (E (<< Gamma, p, (args, fake_bot), sigma >>), K) ^\ Value

| App_Eval : forall cp Gamma p args Value e clovars clo_e sigma fake_bot K
  (CS      : find_cs cs cp = CS_lf (Lf Update clovars 0 e))
  (ONHEAP1 : Gamma p = Some (cp, clo_e))
  (* NO CLOG !!! *)
  (PREMISE : cs @@ (E (<< Gamma, e, sigma, (args, length args), p >>), K_upd p fake_bot :: K) ^\ Value),
  cs @@ (E (<< Gamma, p, (args, fake_bot), sigma >>), K) ^\ Value

| App3 : forall p C addrs Delta theta args fake_bot fake_bot_dummy K Value
  (ARGSNIL : fake_bot = length args)
  (PREMISE : cs @@ (A (Val_con (set Delta p (CP_cons C (length addrs), addrs)) C addrs, theta, (args, fake_bot)), K) ^\ Value),
  cs @@ (A (Val_con Delta C addrs, theta, (args, fake_bot)), K_upd p fake_bot_dummy :: K) ^\ Value

| App4 : forall p Value q addrs Delta theta args0 fake_bot fake_bot0 K
  (PREMISE : cs @@ (E (<< set Delta p (CP_pap (length addrs), q :: addrs), q, (addrs++args0, fake_bot), theta >>), K) ^\ Value),
  cs @@ (A (Val_pap Delta q addrs, theta, (args0, fake_bot0)), K_upd p fake_bot :: K) ^\ Value

| Let : forall Gamma e lfs sigma closures Value addrs args pclo K
  (LENGTH  : length addrs = length lfs)
  (FRESH   : forall p : address, In p addrs -> Gamma p = None)
  (CLOS    : make_closures (addrs++sigma) Gamma pclo lfs = Some closures)
  (PREMISE : cs @@ (E (<< alloc Gamma addrs closures, e, addrs++sigma, args, pclo >>), K) ^\ Value),
  cs @@ (E (<< Gamma, Letrec lfs e, sigma, args, pclo >>), K) ^\ Value

| Case_of_Eval : forall Gamma e als sigma pclo Value args fake_bot K
  (PREMISE : cs @@ (E (<< Gamma, e, sigma, (args, length args), pclo >>), K_alt als fake_bot :: K) ^\ Value),
  cs @@ (E (<< Gamma, Case e als, sigma, (args, fake_bot), pclo >>), K) ^\ Value

| Case_of_Apply : forall p_als als pclo Value bind Delta p_e0 e0 C addrs theta args0 fake_bot fake_bot0 K
  (CS1     : find_cs cs p_als = CS_alts als)
  (SELECT  : nth C als = Some (Alt bind p_e0))
  (CS2     : find_cs cs p_e0 = CS_expr e0)
  (PREMISE : cs @@ (E (<< Delta, e0, addrs++theta, (args0, fake_bot), pclo >>), K) ^\ Value),
  cs @@ (A (Val_con Delta C addrs, theta, (args0, fake_bot0)), K_alt p_als fake_bot :: K) ^\ Value

where "cs @@ a ^\ b " := (Sem cs a b).


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                Typed LambdaFactor Calculus                         *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                        LamSF_Confluence.v                          *)
(*                                                                    *)
(* adapted from Confluence.v for Lambda Calculus                      *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Test.
Require Import General.
Require Import LamSF_Terms.
Require Import LamSF_Tactics.
Require Import Beta_Reduction.
Require Import LamSF_Redexes.
Require Import LamSF_Marks.
Require Import LamSF_Substitution.
Require Import LamSF_Residuals.
Require Import LamSF_Simulation.
Require Import LamSF_Cube.

(* Confluence *)

Definition confluence (A : Set) (R : A -> A -> Prop) :=
  forall x y : A,
  R x y -> forall z : A, R x z -> exists u : A, R y u /\ R z u.

(***************************************)
(* Parallel moves lemma and confluence *)
(***************************************)

Lemma parallel_moves : confluence lamSF par_red1.
Proof.

red in |- *; intros M N R1 P R2.
elim (simulation M N); trivial with arith.
elim (simulation M P); trivial with arith.
intros V RV U RU.
elim (paving U V (mark M) (mark N) (mark P)); trivial with arith.
intros UV C1; elim C1.
intros VU C2; elim C2.
intros UVW C3; elim C3; intros P1 P2.
exists (unmark UVW); split.
rewrite (inverse N).
apply completeness with VU; trivial with arith.
rewrite (inverse P).
apply completeness with UV; trivial with arith.

Qed.

Lemma confluence_parallel_reduction : confluence lamSF par_red.
Proof.
red.
eapply2 diamond_tiling.
eapply2 parallel_moves.
Qed.


Require Export Qual.metalib.
Require Export Qual.tactics.
Require Export Qual.labels.

Set Implicit Arguments.
Open Scope grade_scope.

(* Helps with specializing the IH for weakening proofs. *)
Local Ltac weakening_ih :=
    match goal with
    | [ H3 : forall P5 P4, [(?x, ?psi0)] ++ ?P2 ++ ?P1 = P4 ++ P5 -> _ |- _ ]
     => specialize (H3 P1 (x ~ psi0 ++ P2) ltac:(eauto) ltac:(simpl_env;auto)); simpl_env in H3
     end.

Lemma CGrade_Grade_weakening_middle : (forall P psi psi0 b,
    CGrade P psi psi0 b -> forall P1 P2, P = P2 ++ P1 -> forall P3,
     uniq (P2 ++ P3 ++ P1)
    -> CGrade (P2 ++ P3 ++ P1) psi psi0 b) /\ (forall P psi b,
    Grade P psi b -> forall P1 P2, P = P2 ++ P1 -> forall P3,
     uniq (P2 ++ P3 ++ P1)
    -> Grade (P2 ++ P3 ++ P1) psi b).
Proof.
  eapply CGrade_Grade_mutual.
  all: intros; eauto.
  all: try solve [subst; eapply G_Var; eauto].

  all: try solve
        [subst; fresh_apply_Grade x; eauto;
         repeat spec x;
         weakening_ih;
         eauto].
Qed.

Lemma Grade_weakening_middle : forall P1 P2 P3 psi b,
    Grade (P2 ++ P1) psi b -> uniq (P2 ++ P3 ++ P1)
    -> Grade (P2 ++ P3 ++ P1) psi b.
Proof.
  intros.   eapply CGrade_Grade_weakening_middle; eauto. Qed.

Lemma Grade_weakening : forall P2 P1 psi b,
    Grade P1 psi b
    -> uniq (P2 ++ P1)
    -> Grade (P2 ++ P1) psi b.
Proof.
  intros.
  eapply CGrade_Grade_weakening_middle with (P2 := nil); simpl_env; eauto.
Qed.

Ltac geq_weakening_ih :=
    match goal with
    | [ H3 : forall P3 P4, [(?x, ?psi0)] ++ ?P2 ++ ?P1 = P4 ++ P3 -> _ |- _ ]
     => specialize (H3 P1 ([(x,psi0)] ++ P2) ltac:(eauto) _ ltac:(simpl_env;eauto)); simpl_env in H3
     end.

Lemma CEq_GEq_weakening :
  (forall P phi phi0 a b,
  CEq P phi phi0 a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> CEq (P2 ++ P3 ++ P1) phi phi0 a b) /\
  (forall P phi a b,
  GEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> GEq (P2 ++ P3 ++ P1) phi a b).
Proof.
  eapply CEq_GEq_mutual.
  all: intros; eauto.
  all: try solve [subst; eapply GEq_Var; eauto].
  all: try solve [subst;
    fresh_apply_GEq x; eauto;
    repeat spec x;
    geq_weakening_ih;
    eauto].
Qed.

Lemma GEq_weakening_middle :  (forall P phi a b,
  GEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> GEq (P2 ++ P3 ++ P1) phi a b).
Proof.
  destruct CEq_GEq_weakening.
  auto.
Qed.

Lemma GEq_weakening : forall P phi b1 b2,
  GEq P phi b1 b2 -> forall P2, uniq (P2 ++ P) -> GEq (P2 ++ P) phi b1 b2.
Proof.
  destruct CEq_GEq_weakening.
  intros.
  eapply H0 with (P2 := nil); eauto.
Qed.

Lemma CDefEq_DefEq_weakening_middle :
  (forall P phi psi a b,
  CDefEq P phi psi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> CDefEq (P2 ++ P3 ++ P1) phi psi a b) /\
  (forall P phi a b,
  DefEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> DefEq (P2 ++ P3 ++ P1) phi a b).
Proof.
  apply CDefEq_DefEq_mutual.
  all: intros; subst; eauto 3 using Grade_weakening_middle.
  all: try solve [subst;
    fresh_apply_DefEq x; auto;
    repeat spec x;
    geq_weakening_ih;
    eauto].
  all: try solve [
             pick fresh x and apply Eq_SubstIrrel; eauto 2;
             repeat spec x;
             geq_weakening_ih;
             eauto].

  all: eauto 4 using Grade_weakening_middle.
  all: try (eapply Eq_Case; eauto 3 using Grade_weakening_middle).
Qed.

Lemma DefEq_weakening_middle :
  (forall P phi a b,
  DefEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> DefEq (P2 ++ P3 ++ P1) phi a b).
Proof.
  intros.
  eapply CDefEq_DefEq_weakening_middle; eauto.
Qed.

Lemma DefEq_weakening : forall P phi b1 b2,
  DefEq P phi b1 b2 -> forall P2, uniq (P2 ++ P) -> DefEq (P2 ++ P) phi b1 b2.
Proof.
  intros.
  eapply CDefEq_DefEq_weakening_middle with (P2 := nil); eauto.
Qed.

Lemma CPar_Par_weakening_middle :
  (forall G0 psi psi0 a b, CPar G0 psi psi0 a b ->
  forall E F G, (G0 = F ++ G) -> uniq (F ++ E ++ G) ->  CPar (F ++ E ++ G) psi psi0 a b) /\
  (forall G0 psi a b, Par G0 psi a b ->
  forall E F G, (G0 = F ++ G) -> uniq (F ++ E ++ G) ->  Par (F ++ E ++ G) psi a b).
Proof.
  apply CPar_Par_mutual.
  all: intros; subst; eauto 3 using Grade_weakening_middle.
  all: try solve [
  subst; fresh_apply_Par x; auto; repeat spec x;
  match goal with
  | [ H3 : forall E F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G = F0 ++ G0 -> _ |- _ ]
    =>  specialize (H3 E ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto) ltac:(simpl_env;eauto)) ;
  simpl_env in H3 end; eauto].

  all: eauto 5 using Grade_weakening_middle.
Qed.

Lemma Par_weakening_middle :
  forall G0 a psi b, Par G0 psi a b ->
  forall E F G, (G0 = F ++ G) -> uniq (F ++ E ++ G) ->  Par (F ++ E ++ G) psi a b.
Proof.
  intros. eapply CPar_Par_weakening_middle; eauto.
Qed.

Lemma Par_weakening :
  forall G a psi b, Par G psi a b ->
  forall E, uniq (E ++ G) ->  Par (E ++ G) psi a b.
Proof.
  intros. eapply Par_weakening_middle with (F := nil); eauto.
Qed.

Lemma Typing_weakening_middle : forall W2 W1 q b B,
    Typing (W2 ++ W1) q b B ->
    forall W, uniq (W2 ++ W ++ W1) ->
    Typing (W2 ++ W ++ W1) q b B.
Proof.
  intros W2 W1 q b B h. dependent induction h.
  all: intros; subst; eauto 3 using DefEq_weakening_middle.
  all: have UL1: uniq (meet_ctx_l q_C W2 ++ meet_ctx_l q_C W ++ meet_ctx_l q_C W1) by
    unfold meet_ctx_l; solve_uniq.
  all: have UL2: uniq (labels (meet_ctx_l q_C W2) ++ labels (meet_ctx_l q_C W) ++ labels (meet_ctx_l q_C W1)) by
   unfold labels; solve_uniq.
  (* easy cases *)
  all: try solve [eapply T_App; eauto].
  all: try solve [
             eapply T_AppIrrel; simpl_env; eauto;
             eapply IHh2; simpl_env; eauto].
  all: try solve [
             eapply T_WPair; simpl_env; eauto;
             eapply IHh1; simpl_env; eauto].
  all: try solve [
             eapply T_WPairIrrel; simpl_env; eauto;
             try eapply IHh1; simpl_env; eauto;
             try eapply IHh2; simpl_env; eauto].
  all: try solve [
             eapply T_SPair; simpl_env; eauto;
             try eapply IHh1; simpl_env; eauto;
             try eapply IHh2; simpl_env; eauto].
  all: try solve [
             apply T_Sum; simpl_env; eauto;
             try eapply IHh1; simpl_env; eauto;
             try eapply IHh2; simpl_env; eauto].
  all: try solve [
             eapply T_Inj1; simpl_env; eauto;
             eapply IHh2; simpl_env; eauto].
  all: try solve [
             eapply T_Inj2; simpl_env; eauto;
             eapply IHh2; simpl_env; eauto].
  all: try solve [eapply T_Eq; simpl_env; eauto].

  (* conversion *)
  all: try match goal with [ H : DefEq _ _ _ _ |- _ ] =>
                  eapply T_Conv; eauto 3;
                    simpl_env in *;
                    try eapply DefEq_weakening_middle; eauto end.

  (* pi *)
  subst; fresh_apply_Typing x; eauto 1; auto; repeat spec x;
  match goal with
  | [ H2 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ]
    => specialize (H2 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3));
  simpl_env in H2; eauto 3; try eapply H2; try solve_uniq end.

  (* abs *)
  subst; fresh_apply_Typing x; simpl_env; try eapply IHh; simpl_env; eauto; repeat spec x;
  try match goal with
  | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ]
    => specialize (H3 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3) W) ;
  simpl_env in H3 ; eauto 3; try eapply H3 end.

  (* wsigma *)
  subst; fresh_apply_Typing x; eauto 1; auto; repeat spec x;
  match goal with
  | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ]
    => specialize (H3 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3)) ;
  simpl_env in H3; eauto 3; try eapply H3; try solve_uniq end.

  (* letpair *)
  - subst; fresh_apply_Typing x.
    + clear H H1 H2 IHh.
    repeat spec x. simpl_env.
    match goal with
    | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ meet_ctx_l q_C (?F ++ ?G) ~= F0 ++ G0 -> _ |- _ ]
      => specialize (H3 ([(x,psi0)] ++ meet_ctx_l q_C F) (meet_ctx_l q_C G) ltac:(simpl_env;eauto 3) (meet_ctx_l q_C W));
          simpl_env in H3; eapply H3 end.
    eapply uniq_cons_3; auto. repeat rewrite dom_app. repeat rewrite dom_meet_ctx_l. auto.
    + eapply IHh; auto.
    + move => y Fry.
      clear H H0 H1 IHh.
      spec x. spec y.
      specialize (H0 ([(x, (psi0 * psi,A))] ++ W2) W1 ltac:(simpl_env; auto) W).
      simpl_env in H0. eapply H0. solve_uniq.

  (* ssigma *)
  - subst; fresh_apply_Typing x; eauto 1; auto; repeat spec x;
      match goal with
      | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ]
        => specialize (H3 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3)) ;
            simpl_env in H3; eauto 3; try eapply H3; try solve_uniq end.
  - (* case *)
    fresh_apply_Typing x; auto.
    repeat spec x.
    simpl_env.
    match goal with
    | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ meet_ctx_l q_C (?F ++ ?G) ~= F0 ++ G0 -> _ |- _ ]
      => specialize (H3 ([(x,psi0)] ++ meet_ctx_l q_C F) (meet_ctx_l q_C G) ltac:(simpl_env;eauto 3)
                   (meet_ctx_l q_C W));
          simpl_env in H3 ; eapply H3 end.
    eapply uniq_cons_3; auto. repeat rewrite dom_app. repeat rewrite dom_meet_ctx_l. auto.
Qed.

Lemma Typing_weakening : forall W1 q b B,
    Typing W1 q b B ->
    forall W2, uniq (W2 ++ W1) ->
    Typing (W2 ++ W1) q b B.
Proof.
  intros.
  eapply Typing_weakening_middle with (W2 := nil); simpl_env; eauto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal35.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Succ (Succ Zero)).
Definition lfind_example_2  := ( Succ Zero).
Definition lfind_example_3  := ( Succ         (Succ            (Succ               (Succ                  (Succ                     (Succ                        (Succ                           (Succ                              (Succ                                 (Succ                                    (Succ                                       (Succ (Succ (Succ (Succ (Succ Zero)))))))))))))))).
Definition lfind_example_4  := ( Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))))).
Definition lfind_example_5  := ( Zero).
Definition lfind_example_6  := ( Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))))).
Definition lfind_example_7  := ( Zero).
Definition lfind_example_8  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_9  := ( Succ Zero).
Definition lfind_example_10  := ( Succ Zero).
Definition lfind_example_11  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_12  := ( Zero).
Definition lfind_example_13  := ( Zero).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_exp_eq_qexp_119_mult_qexp/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 .


Require Import Common.Definitions.
Require Import Common.Values.
Require Import Source.CS.
Require Import Source.GlobalEnv.

Require Export Source.Language.
Require Export Extraction.Definitions.

Import Source.

Definition run (p: program) (fuel: nat) :=
  let G := prepare_global_env p in
  let st := CS.initial_machine_state p in
  match CS.execN fuel G st with
  | Some [CState _, _, _, _, E_exit, _] => print_explicit_exit tt
  | Some [CState _, _, _, _, E_val (Int n), _] => print_ocaml_int (z2int n)
  | _ => print_error ocaml_int_0
  end.


(* First a simplification of the bug *)

Set Printing Universes.

Inductive enc (A:Type (*1*)) (* : Type.1 *) := C : A -> enc A.

Definition id (X:Type(*5*)) (x:X) := x.

Lemma test : let S := Type(*6 : 7*) in enc S -> S.
simpl; intros.
apply enc.
apply id.
apply Prop.
Defined.

(* Then the original bug *)

Require Import List.

Inductive a : Set := (* some dummy inductive *)
b : (list a) -> a.   (* i don't know if this *)
                     (* happens for smaller  *)
                     (* ones                 *)

Inductive sg : Type := Sg. (* single *)

Definition ipl2 (P : a -> Type) :=   (* in Prop, that means P is true forall *)
fold_right (fun x => prod (P x)) sg. (* the elements of a given list         *)

Definition ind
     : forall S : a -> Type,
       (forall ls : list a, ipl2 S ls -> S (b ls)) -> forall s : a, S s :=
fun (S : a -> Type)
  (X : forall ls : list a, ipl2 S ls -> S (b ls)) =>
fix ind2 (s : a) :=
match s as a return (S a) with
| b l =>
    X l
      (list_rect (fun l0 : list a => ipl2 S l0) Sg
         (fun (a0 : a) (l0 : list a) (IHl : ipl2 S l0) =>
          pair (ind2 a0) IHl) l)
end. (* some induction principle *)

Implicit Arguments ind [S].

Lemma k : a -> Type. (* some ininteresting lemma *)
intro;pattern H;apply ind;intros.
  assert (K : Type).
    induction ls.
      exact sg.
      exact sg.
  exact (prod K sg).
Defined.

Lemma k' : a -> Type. (* same lemma but with our bug *)
intro;pattern H;apply ind;intros.
  apply prod.
    induction ls.
      exact sg.
      exact sg.
    exact sg. (* Proof complete *)
Defined. (* bug *)


Require Import RGref.DSL.Core.

(** * Helpful Constants, Lemmas, and Proof Tactics *)
(** ** General stufff *)
Definition any {A:Set} : hpred A := fun _ => fun _ => True.

Lemma stable_any : forall (A:Set) (R:hrel A), stable any R.
Proof.
  intros; compute; eauto.
Qed.
Hint Resolve stable_any.
Lemma precise_any : forall (A:Set){RA:ImmediateReachability A}, @precise_pred A RA any.
Proof.
  intros; compute; eauto.
Qed.
Hint Resolve precise_any.
Lemma any_true : forall (A:Set) (a:A) h, any a h.
Proof. compute; auto. Qed.
Hint Resolve any_true.

Definition havoc {A:Set} : hrel A := fun _ => fun _ => fun _ => fun _ => True.
Lemma precise_havoc : forall (A:Set)`{ImmediateReachability A}, precise_rel (@havoc A).
Proof. intros; compute; eauto. Qed.
Hint Resolve precise_havoc.
Lemma havoc_true : forall (A:Set) (a a':A) h h', havoc a a' h h'.
Proof. intros; compute; auto. Qed.
Hint Resolve havoc_true.
Lemma havoc_refl : forall (A:Set), hreflexive (@havoc A).
Proof. compute; eauto. Qed.
Hint Resolve havoc_refl.

Definition empty {A:Set} : hrel A := fun _ => fun _ => fun _ => fun _ => False.
Definition locally_const {A:Set} (R:hrel A) := forall a a' h h', R a a' h h' -> a=a'.

Lemma stable_empty : forall (A:Set) (P:hpred A), stable P empty.
Proof.
  compute; intuition.
Qed.
Hint Resolve stable_empty.
Lemma precise_empty : forall (A:Set)`{ImmediateReachability A}, precise_rel empty.
Proof. intros; compute; eauto. Qed.
Hint Resolve precise_empty.

Definition local_imm {A:Set} : hrel A := fun a => fun a' => fun _ => fun _ => a=a'.
Lemma local_imm_const : forall A, locally_const (@local_imm A).
Proof. intros; firstorder. Qed.
Hint Resolve local_imm_const.
Lemma local_imm_precise : forall (T:Set)`{ImmediateReachability T}, precise_rel (@local_imm T).
Proof.
  red; intros. induction H2. red. reflexivity.
Qed.
Hint Resolve local_imm_precise.
Lemma local_imm_refl : forall (T:Set), @hreflexive T local_imm.
Proof.
  compute; eauto.
Qed.
Hint Resolve local_imm_refl.
Axiom immutable_vals :
  forall T P h h' (r:ref{T|P}[local_imm,local_imm]), h[r]=h'[r].

(** We can always read when we have only one writable ref *)
Global Instance strong_read (T:Set) : readable_at T local_imm havoc :=
  { res := T ;
    dofold := fun x => x
  }.
(** And we can always read when the guarantee is strictly local *)
Global Instance weak_read (T:Set) : readable_at T local_imm local_imm :=
  { res := T ;
    dofold := fun x => x
  }.
(** I'm torn about providing this, but it's a common enough pattern (it is
    the common case that types are only read at one R/G) that
    we should(?) make it easy as a matter of library design...*)
Definition id_fold {T:Set}{R G:hrel T} : readable_at T R G :=
  Build_readable_at T R G T (fun x => x).

Definition heap_agnostic_pred {A:Set} (P:hpred A) := forall a h h', P a h -> P a h'.
Definition heap_agnostic_rel {A:Set} (R:hrel A) := forall a a' h h' h'' h''', R a a' h h' -> R a a' h'' h'''.

Lemma agnostic_pred_stable : forall (A:Set) (P:hpred A), heap_agnostic_pred P -> stable P local_imm.
Proof.
  compute. intros. subst; intuition; eauto.
Qed.

Hint Resolve agnostic_pred_stable.

(** *** Option types *)
Inductive optset (A:Set) : hrel (option A) :=
  | optset_nop : forall (o:option A) h h', optset A o o h h'
  | optset_set : forall (a:A) h h', optset A None (Some a) h h'.
Inductive option_reach : forall (A:Set)`(ImmediateReachability A) {T:Set}{P R G} (p:ref{T|P}[R,G]) (ao:option A), Prop :=
  | opt_reach_some : forall (A:Set)(a:A)`(ImmediateReachability A) {T:Set}{P R G} (p:ref{T|P}[R,G]),
                         imm_reachable_from_in p a ->
                         option_reach A _ p (Some a).
Global Instance reach_option {A:Set}`{ImmediateReachability A} : ImmediateReachability (option A) :=
  { imm_reachable_from_in := fun T P R G p oa => option_reach A _ p oa }.
Lemma optset_precise : forall A `(ImmediateReachability A), precise_rel (optset A).
Proof. compute. intros. inversion H2; subst; constructor. Qed.
Hint Resolve optset_precise.
(* TODO: Contains instance for options *)
Global Instance option_fold {A:Set}`{rel_fold A} : rel_fold (option A) :=
  { rgfold := fun R G => option (rgfold havoc (fun a a' h h' => G (Some a) (Some a') h h')) ;
    fold := fun R G o => match o with None => None | Some o' => Some (fold o') end
  }.
Lemma optset_refl : forall (A:Set), hreflexive (optset A).
Proof. compute; intuition; constructor. Qed.
Hint Resolve optset_refl.
Inductive opt_contains {A:Set}`{Containment A} : hrel (option A) -> Prop :=
  | some_contains : forall RR (h h':heap),
                      contains (fun a a' h h' => RR (Some a) (Some a') h h') ->
                      opt_contains RR.
Global Instance option_contains {A:Set}`{Containment A} : Containment (option A) :=
  { contains := opt_contains }.

(** ** Combinator Lemmas *)

Lemma pred_and_stable : forall (A:Set) (P:hpred A) Q R, stable P R -> stable Q R -> stable (P ⊓ Q) R.
Proof. intros; firstorder. Qed.
Lemma pred_or_stable : forall (A:Set) (P Q:hpred A) R, stable P R -> stable Q R -> stable (P ⊔ Q) R.
Proof. intros; firstorder. Qed.
Lemma rel_and_stable : forall (A:Set) (P:hpred A) R S, stable P R -> stable P S -> stable P (R ⋂ S).
Proof. intros; firstorder. Qed.
Lemma rel_or_stable : forall (A:Set) (P:hpred A) R S, stable P R -> stable P S -> stable P (R ⋃ S).
Proof. intros; firstorder. Qed.
Lemma pred_and_precise : forall (A:Set){RA:ImmediateReachability A}(P Q:hpred A), precise_pred P -> precise_pred Q -> precise_pred (P ⊓ Q).
Proof. intros; firstorder. Qed.
Lemma pred_or_precise : forall (A:Set){RA:ImmediateReachability A}(P Q:hpred A), precise_pred P -> precise_pred Q -> precise_pred (P ⊔ Q).
Proof. intros; firstorder. Qed.
Lemma rel_and_precise : forall (A:Set){RA:ImmediateReachability A}(R S:hrel A), precise_rel R -> precise_rel S -> precise_rel (R ⋂ S).
Proof. intros. compute[precise_rel rel_and] in *. intuition. eauto. eauto. Qed.
Lemma rel_or_precise : forall (A:Set){RA:ImmediateReachability A}(R S:hrel A), precise_rel R -> precise_rel S -> precise_rel (R ⋃ S).
Proof. intros. compute[precise_rel rel_or] in *. intuition. eauto. eauto. Qed.
Require Import Coq.Classes.RelationClasses.
Global Instance rel_sub_eq_preorder `{A:Set} : PreOrder (@rel_sub_eq A).
Proof. constructor. firstorder. firstorder. Qed.
Global Instance pred_sub_eq_preorder `{A:Set} : PreOrder (@pred_sub_eq A).
Proof. constructor; firstorder. Qed.

Lemma pred_sub_refl : forall T (P:hpred T), P⊑P.
Proof.
  reflexivity.
Qed.
Hint Resolve pred_sub_refl.

Lemma rel_sub_refl : forall T (R:hrel T), R⊆R.
Proof.
  reflexivity.
Qed.
Hint Resolve rel_sub_refl.

(** Also need to be able to pull results out of conjunctions *)
Lemma pred_and_proj1 : forall (A:Set) P Q (a:A) (h:heap), (P ⊓ Q) a h -> P a h.
Proof. firstorder. Qed.
Lemma pred_and_proj2 : forall (A:Set) P Q (a:A) (h:heap), (P ⊓ Q) a h -> Q a h.
Proof. firstorder. Qed.

Hint Resolve pred_and_stable rel_and_stable pred_and_precise rel_and_precise.
Hint Resolve pred_or_stable rel_or_stable pred_or_precise rel_or_precise.


From Coq Require Import
     List.
From Test Require Import
     Testable
     TestableType
     TestableLaws.
Import
  ListNotations.
Open Scope bool_scope.

Class TestableTypeLaws (T : Type) `{TestableType T} :=
  { TestableLaws_eq {x y : T} : @TestableLaws (x = y) Testable_eq }.

Global Instance TestableLaws_In {T} `{TestableTypeLaws T, a : T, l : list T} :
  TestableLaws (In a l).
Proof with auto.
  destruct H0.
  induction l.
  - split...
    + exists 0. exists false...
    + intros. discriminate H0.
  - destruct (TestableLaws_eq0 a a0).
    destruct IHl.
    split; intros.
    + destruct test_live  as [fuel  [result ]].
      destruct test_live0 as [fuel0 [result0]].
      exists (max fuel fuel0); exists (result || result0); simpl in *.
      rewrite (test_monotone  fuel  result )...
      rewrite (test_monotone0 fuel0 result0)...
      destruct result; destruct result0...
    + simpl in *.
      destruct (test (a = a0) fuel) as [[]|] eqn:Htest.
      * rewrite (test_monotone fuel true )...
      * rewrite (test_monotone fuel false)...
        destruct (test_In a l fuel) as [[]|] eqn:Htest0; inversion H0;
        rewrite (test_monotone0 fuel result); subst...
      * destruct (test_In a l fuel) as [[]|] eqn:Htest0; inversion H0; subst.
        rewrite (test_monotone0 fuel true)...
        destruct (test (a = a0) fuel') as [[]|]...
    + simpl in *.
      destruct (test (a = a0) fuel) as [[]|] eqn:Htest ;
      destruct (test_In a l   fuel) as [[]|] eqn:Htest0;
      inversion H0;
      try apply test_sound_true  in Htest;
      try apply test_sound_true0 in Htest0...
    + simpl in *.
      destruct (test (a = a0) fuel) as [[]|] eqn:Htest ;
      destruct (test_In a l   fuel) as [[]|] eqn:Htest0;
      inversion H0.
      apply test_sound_false  in Htest .
      apply test_sound_false0 in Htest0.
      intro. destruct H1...
Defined.