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 *)
(** ** 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. *)
(** [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.
(** The proof that transitions preserve semantics (up to the values of temporary registers) follows. *)
(** 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]. *)
(** * 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. *)
(** The semantic correctness of deterministic transitions follows. *)
(** * 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. *)
Fixpoint 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.
Fixpoint 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.
Fixpoint 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. *)
(** 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.
(** 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).
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. *)
(** 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.