(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(** Correctness proof for the [Allocation] pass (validated translation from RTL to LTL). *)
Require Archi.
Definition match_prog (p: RTL.program) (tp: LTL.program) :=
match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
(** * Soundness of structural checks *)
Definition expand_move (m: move) : instruction :=
match m with
| MV (R src) (R dst) => Lop Omove (src::nil) dst
| MV (S sl ofs ty) (R dst) => Lgetstack sl ofs ty dst
| MV (R src) (S sl ofs ty) => Lsetstack src sl ofs ty
| MV (S _ _ _) (S _ _ _) => Lreturn    (**r should never happen *)
| MVmakelong src1 src2 dst => Lop Omakelong (src1::src2::nil) dst
| MVlowlong src dst => Lop Olowlong (src::nil) dst
| MVhighlong src dst => Lop Ohighlong (src::nil) dst
end.
Definition expand_moves (mv: moves) (k: bblock) : bblock :=
List.map expand_move mv ++ k.
Definition wf_move (m: move) : Prop :=
match m with
| MV (S _ _ _) (S _ _ _) => False
| _ => True
end.
Definition wf_moves (mv: moves) : Prop :=
List.Forall wf_move mv.
Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Prop :=
| ebs_nop: forall mv s k,
wf_moves mv ->
expand_block_shape (BSnop mv s)
(Inop s)
(expand_moves mv (Lbranch s :: k))
| ebs_move: forall src dst mv s k,
wf_moves mv ->
expand_block_shape (BSmove src dst mv s)
(Iop Omove (src :: nil) dst s)
(expand_moves mv (Lbranch s :: k))
| ebs_makelong: forall src1 src2 dst mv s k,
wf_moves mv ->
Archi.splitlong = true ->
expand_block_shape (BSmakelong src1 src2 dst mv s)
(Iop Omakelong (src1 :: src2 :: nil) dst s)
(expand_moves mv (Lbranch s :: k))
| ebs_lowlong: forall src dst mv s k,
wf_moves mv ->
Archi.splitlong = true ->
expand_block_shape (BSlowlong src dst mv s)
(Iop Olowlong (src :: nil) dst s)
(expand_moves mv (Lbranch s :: k))
| ebs_highlong: forall src dst mv s k,
wf_moves mv ->
Archi.splitlong = true ->
expand_block_shape (BShighlong src dst mv s)
(Iop Ohighlong (src :: nil) dst s)
(expand_moves mv (Lbranch s :: k))
| ebs_op: forall op args res mv1 args' res' mv2 s k,
wf_moves mv1 -> wf_moves mv2 ->
expand_block_shape (BSop op args res mv1 args' res' mv2 s)
(Iop op args res s)
(expand_moves mv1
(Lop op args' res' :: expand_moves mv2 (Lbranch s :: k)))
| ebs_op_dead: forall op args res mv s k,
wf_moves mv ->
expand_block_shape (BSopdead op args res mv s)
(Iop op args res s)
(expand_moves mv (Lbranch s :: k))
| ebs_load: forall chunk addr args dst mv1 args' dst' mv2 s k,
wf_moves mv1 -> wf_moves mv2 ->
expand_block_shape (BSload chunk addr args dst mv1 args' dst' mv2 s)
(Iload chunk addr args dst s)
(expand_moves mv1
(Lload chunk addr args' dst' :: expand_moves mv2 (Lbranch s :: k)))
| ebs_load2: forall addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s k,
wf_moves mv1 -> wf_moves mv2 -> wf_moves mv3 ->
Archi.splitlong = true ->
offset_addressing addr 4 = Some addr2 ->
expand_block_shape (BSload2 addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s)
(Iload Mint64 addr args dst s)
(expand_moves mv1
(Lload Mint32 addr args1' dst1' ::
expand_moves mv2
(Lload Mint32 addr2 args2' dst2' ::
expand_moves mv3 (Lbranch s :: k))))
| ebs_load2_1: forall addr args dst mv1 args' dst' mv2 s k,
wf_moves mv1 -> wf_moves mv2 ->
Archi.splitlong = true ->
expand_block_shape (BSload2_1 addr args dst mv1 args' dst' mv2 s)
(Iload Mint64 addr args dst s)
(expand_moves mv1
(Lload Mint32 addr args' dst' ::
expand_moves mv2 (Lbranch s :: k)))
| ebs_load2_2: forall addr addr2 args dst mv1 args' dst' mv2 s k,
wf_moves mv1 -> wf_moves mv2 ->
Archi.splitlong = true ->
offset_addressing addr 4 = Some addr2 ->
expand_block_shape (BSload2_2 addr addr2 args dst mv1 args' dst' mv2 s)
(Iload Mint64 addr args dst s)
(expand_moves mv1
(Lload Mint32 addr2 args' dst' ::
expand_moves mv2 (Lbranch s :: k)))
| ebs_load_dead: forall chunk addr args dst mv s k,
wf_moves mv ->
expand_block_shape (BSloaddead chunk addr args dst mv s)
(Iload chunk addr args dst s)
(expand_moves mv (Lbranch s :: k))
| ebs_store: forall chunk addr args src mv1 args' src' s k,
wf_moves mv1 ->
expand_block_shape (BSstore chunk addr args src mv1 args' src' s)
(Istore chunk addr args src s)
(expand_moves mv1
(Lstore chunk addr args' src' :: Lbranch s :: k))
| ebs_store2: forall addr addr2 args src mv1 args1' src1' mv2 args2' src2' s k,
wf_moves mv1 -> wf_moves mv2 ->
Archi.splitlong = true ->
offset_addressing addr 4 = Some addr2 ->
expand_block_shape (BSstore2 addr addr2 args src mv1 args1' src1' mv2 args2' src2' s)
(Istore Mint64 addr args src s)
(expand_moves mv1
(Lstore Mint32 addr args1' src1' ::
expand_moves mv2
(Lstore Mint32 addr2 args2' src2' ::
Lbranch s :: k)))
| ebs_call: forall sg ros args res mv1 ros' mv2 s k,
wf_moves mv1 -> wf_moves mv2 ->
expand_block_shape (BScall sg ros args res mv1 ros' mv2 s)
(Icall sg ros args res s)
(expand_moves mv1
(Lcall sg ros' :: expand_moves mv2 (Lbranch s :: k)))
| ebs_tailcall: forall sg ros args mv ros' k,
wf_moves mv ->
expand_block_shape (BStailcall sg ros args mv ros')
(Itailcall sg ros args)
(expand_moves mv (Ltailcall sg ros' :: k))
| ebs_builtin: forall ef args res mv1 args' res' mv2 s k,
wf_moves mv1 -> wf_moves mv2 ->
expand_block_shape (BSbuiltin ef args res mv1 args' res' mv2 s)
(Ibuiltin ef args res s)
(expand_moves mv1
(Lbuiltin ef args' res' :: expand_moves mv2 (Lbranch s :: k)))
| ebs_cond: forall cond args mv args' s1 s2 k,
wf_moves mv ->
expand_block_shape (BScond cond args mv args' s1 s2)
(Icond cond args s1 s2)
(expand_moves mv (Lcond cond args' s1 s2 :: k))
| ebs_jumptable: forall arg mv arg' tbl k,
wf_moves mv ->
expand_block_shape (BSjumptable arg mv arg' tbl)
(Ijumptable arg tbl)
(expand_moves mv (Ljumptable arg' tbl :: k))
| ebs_return: forall optarg mv k,
wf_moves mv ->
expand_block_shape (BSreturn optarg mv)
(Ireturn optarg)
(expand_moves mv (Lreturn :: k)).
Ltac MonadInv :=
match goal with
| [ H: match ?x with Some _ => _ | None => None end = Some _ |- _ ] =>
destruct x as [] eqn:? ; [MonadInv|discriminate]
| [ H: match ?x with left _ => _ | right _ => None end = Some _ |- _ ] =>
destruct x; [MonadInv|discriminate]
| [ H: match negb (proj_sumbool ?x) with true => _ | false => None end = Some _ |- _ ] =>
destruct x; [discriminate|simpl in H; MonadInv]
| [ H: match negb ?x with true => _ | false => None end = Some _ |- _ ] =>
destruct x as [] eqn:? ; [discriminate|simpl in H; MonadInv]
| [ H: match ?x with true => _ | false => None end = Some _ |- _ ] =>
destruct x as [] eqn:? ; [MonadInv|discriminate]
| [ H: match ?x with (_, _) => _ end = Some _ |- _ ] =>
destruct x as [] eqn:? ; MonadInv
| [ H: Some _ = Some _ |- _ ] =>
inv H; MonadInv
| [ H: None = Some _ |- _ ] =>
discriminate
| _ =>
idtac
end.
Remark expand_moves_cons:
forall m accu b,
expand_moves (rev (m :: accu)) b = expand_moves (rev accu) (expand_move m :: b).

Lemma extract_moves_sound:
forall b mv b',
extract_moves nil b = (mv, b') ->
wf_moves mv /\ b = expand_moves mv b'.