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.
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'.
(** 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. *)
(** Some properties of [is_mill] and [dests_disjoint]. *)
Definition dests_disjoint (m1 m2: moves) : Prop :=
list_disjoint (dests m1) (dests m2).
(** Some properties of [move_no_temp]. *)
(** Some properties of [temp_last]. *)
(** Some properties of [is_path]. *)
(** To benefit from some proof automation, we populate a rewrite database with some of the properties above. *)
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 transitions_preserve_wf:
forall st st', transitions st st' -> state_wf st -> state_wf st'.