(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)
(** Register allocation by external oracle and a posteriori validation. *)
Require Archi.
(** The validation algorithm used here is described in "Validating register allocation and spilling", by Silvain Rideau and Xavier Leroy, in Compiler Construction (CC 2010), LNCS 6011, Springer, 2010. *)
(** * Structural checks *)
(** As a first pass, we check the LTL code returned by the external oracle against the original RTL code for structural conformance. Each RTL instruction was transformed into a LTL basic block whose shape must agree with the RTL instruction.  For example, if the RTL instruction is [Istore(Mint32, addr, args, src, s)], the LTL basic block must be of the following shape: - zero, one or several "move" instructions - a store instruction [Lstore(Mint32, addr, args', src')] - a [Lbranch s] instruction.  The [block_shape] type below describes all possible cases of structural maching between an RTL instruction and an LTL basic block. *)
Inductive move: Type :=
| MV (src dst: loc)
| MVmakelong (src1 src2 dst: mreg)
| MVlowlong (src dst: mreg)
| MVhighlong (src dst: mreg).
Definition moves := list move.
Inductive block_shape: Type :=
| BSnop (mv: moves) (s: node)
| BSmove (src: reg) (dst: reg) (mv: moves) (s: node)
| BSmakelong (src1 src2: reg) (dst: reg) (mv: moves) (s: node)
| BSlowlong (src: reg) (dst: reg) (mv: moves) (s: node)
| BShighlong (src: reg) (dst: reg) (mv: moves) (s: node)
| BSop (op: operation) (args: list reg) (res: reg)
(mv1: moves) (args': list mreg) (res': mreg)
(mv2: moves) (s: node)
| BSopdead (op: operation) (args: list reg) (res: reg)
(mv: moves) (s: node)
| BSload (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
(mv1: moves) (args': list mreg) (dst': mreg)
(mv2: moves) (s: node)
| BSloaddead (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
(mv: moves) (s: node)
| BSload2 (addr1 addr2: addressing) (args: list reg) (dst: reg)
(mv1: moves) (args1': list mreg) (dst1': mreg)
(mv2: moves) (args2': list mreg) (dst2': mreg)
(mv3: moves) (s: node)
| BSload2_1 (addr: addressing) (args: list reg) (dst: reg)
(mv1: moves) (args': list mreg) (dst': mreg)
(mv2: moves) (s: node)
| BSload2_2 (addr addr': addressing) (args: list reg) (dst: reg)
(mv1: moves) (args': list mreg) (dst': mreg)
(mv2: moves) (s: node)
| BSstore (chunk: memory_chunk) (addr: addressing) (args: list reg) (src: reg)
(mv1: moves) (args': list mreg) (src': mreg)
(s: node)
| BSstore2 (addr1 addr2: addressing) (args: list reg) (src: reg)
(mv1: moves) (args1': list mreg) (src1': mreg)
(mv2: moves) (args2': list mreg) (src2': mreg)
(s: node)
| BScall (sg: signature) (ros: reg + ident) (args: list reg) (res: reg)
(mv1: moves) (ros': mreg + ident) (mv2: moves) (s: node)
| BStailcall (sg: signature) (ros: reg + ident) (args: list reg)
(mv1: moves) (ros': mreg + ident)
| BSbuiltin (ef: external_function)
(args: list (builtin_arg reg)) (res: builtin_res reg)
(mv1: moves) (args': list (builtin_arg loc)) (res': builtin_res mreg)
(mv2: moves) (s: node)
| BScond (cond: condition) (args: list reg)
(mv: moves) (args': list mreg) (s1 s2: node)
| BSjumptable (arg: reg)
(mv: moves) (arg': mreg) (tbl: list node)
| BSreturn (arg: option reg)
(mv: moves).
(** Classify operations into moves, 64-bit split integer operations, and other arithmetic/logical operations. *)
Inductive operation_kind {A: Type}: operation -> list A -> Type :=
| operation_Omove: forall arg, operation_kind Omove (arg :: nil)
| operation_Omakelong: forall arg1 arg2, operation_kind Omakelong (arg1 :: arg2 :: nil)
| operation_Olowlong: forall arg, operation_kind Olowlong (arg :: nil)
| operation_Ohighlong: forall arg, operation_kind Ohighlong (arg :: nil)
| operation_other: forall op args, operation_kind op args.
Definition classify_operation {A: Type} (op: operation) (args: list A) : operation_kind op args :=
match op, args with
| Omove, arg::nil => operation_Omove arg
| Omakelong, arg1::arg2::nil => operation_Omakelong arg1 arg2
| Olowlong, arg::nil => operation_Olowlong arg
| Ohighlong, arg::nil => operation_Ohighlong arg
| op, args => operation_other op args
end.
(** Extract the move instructions at the beginning of block [b]. Return the list of moves and the suffix of [b] after the moves. Two versions are provided: [extract_moves], which extracts only "true" moves, and [extract_moves_ext], which also extracts the [makelong], [lowlong] and [highlong] operations over 64-bit integers. *)
Fixpoint extract_moves (accu: moves) (b: bblock) {struct b} : moves * bblock :=
match b with
| Lgetstack sl ofs ty dst :: b' =>
extract_moves (MV (S sl ofs ty) (R dst) :: accu) b'
| Lsetstack src sl ofs ty :: b' =>
extract_moves (MV (R src) (S sl ofs ty) :: accu) b'
| Lop op args res :: b' =>
match is_move_operation op args with
| Some arg =>
extract_moves (MV (R arg) (R res) :: accu) b'
| None =>
(List.rev accu, b)
end
| _ =>
(List.rev accu, b)
end.
Fixpoint extract_moves_ext (accu: moves) (b: bblock) {struct b} : moves * bblock :=
match b with
| Lgetstack sl ofs ty dst :: b' =>
extract_moves_ext (MV (S sl ofs ty) (R dst) :: accu) b'
| Lsetstack src sl ofs ty :: b' =>
extract_moves_ext (MV (R src) (S sl ofs ty) :: accu) b'
| Lop op args res :: b' =>
match classify_operation op args with
| operation_Omove arg =>
extract_moves_ext (MV (R arg) (R res) :: accu) b'
| operation_Omakelong arg1 arg2 =>
extract_moves_ext (MVmakelong arg1 arg2 res :: accu) b'
| operation_Olowlong arg =>
extract_moves_ext (MVlowlong arg res :: accu) b'
| operation_Ohighlong arg =>
extract_moves_ext (MVhighlong arg res :: accu) b'
| operation_other _ _ =>
(List.rev accu, b)
end
| _ =>
(List.rev accu, b)
end.
Definition check_succ (s: node) (b: LTL.bblock) : bool :=
match b with
| Lbranch s' :: _ => peq s s'
| _ => false
end.
Notation "'do' X <- A ; B" := (match A with Some X => B | None => None end)
(at level 200, X ident, A at level 100, B at level 200)
: option_monad_scope.
Notation "'assertion' A ; B" := (if A then B else None)
(at level 200, A at level 100, B at level 200)
: option_monad_scope.
Local Open Scope option_monad_scope.
(** Check RTL instruction [i] against LTL basic block [b]. On success, return [Some] with a [block_shape] describing the correspondence. On error, return [None]. *)
Definition pair_Iop_block (op: operation) (args: list reg) (res: reg) (s: node) (b: LTL.bblock) :=
let (mv1, b1) := extract_moves nil b in
match b1 with
| Lop op' args' res' :: b2 =>
let (mv2, b3) := extract_moves nil b2 in
assertion (eq_operation op op');
assertion (check_succ s b3);
Some(BSop op args res mv1 args' res' mv2 s)
| _ =>
assertion (check_succ s b1);
Some(BSopdead op args res mv1 s)
end.
Definition pair_instr_block
(i: RTL.instruction) (b: LTL.bblock) : option block_shape :=
match i with
| Inop s =>
let (mv, b1) := extract_moves nil b in
assertion (check_succ s b1); Some(BSnop mv s)
| Iop op args res s =>
match classify_operation op args with
| operation_Omove arg =>
let (mv, b1) := extract_moves nil b in
assertion (check_succ s b1); Some(BSmove arg res mv s)
| operation_Omakelong arg1 arg2 =>
if Archi.splitlong then
(let (mv, b1) := extract_moves nil b in
assertion (check_succ s b1); Some(BSmakelong arg1 arg2 res mv s))
else
pair_Iop_block op args res s b
| operation_Olowlong arg =>
if Archi.splitlong then
(let (mv, b1) := extract_moves nil b in
assertion (check_succ s b1); Some(BSlowlong arg res mv s))
else
pair_Iop_block op args res s b
| operation_Ohighlong arg =>
if Archi.splitlong then
(let (mv, b1) := extract_moves nil b in
assertion (check_succ s b1); Some(BShighlong arg res mv s))
else
pair_Iop_block op args res s b
| operation_other _ _ =>
pair_Iop_block op args res s b
end
| Iload chunk addr args dst s =>
let (mv1, b1) := extract_moves nil b in
match b1 with
| Lload chunk' addr' args' dst' :: b2 =>
if chunk_eq chunk Mint64 && Archi.splitlong then
assertion (chunk_eq chunk' Mint32);
let (mv2, b3) := extract_moves nil b2 in
match b3 with
| Lload chunk'' addr'' args'' dst'' :: b4 =>
let (mv3, b5) := extract_moves nil b4 in
assertion (chunk_eq chunk'' Mint32);
assertion (eq_addressing addr addr');
assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr''));
assertion (check_succ s b5);
Some(BSload2 addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s)
| _ =>
assertion (check_succ s b3);
if (eq_addressing addr addr') then
Some(BSload2_1 addr args dst mv1 args' dst' mv2 s)
else
(assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr'));
Some(BSload2_2 addr addr' args dst mv1 args' dst' mv2 s))
end
else (
let (mv2, b3) := extract_moves nil b2 in
assertion (chunk_eq chunk chunk');
assertion (eq_addressing addr addr');
assertion (check_succ s b3);
Some(BSload chunk addr args dst mv1 args' dst' mv2 s))
| _ =>
assertion (check_succ s b1);
Some(BSloaddead chunk addr args dst mv1 s)
end
| Istore chunk addr args src s =>
let (mv1, b1) := extract_moves nil b in
match b1 with
| Lstore chunk' addr' args' src' :: b2 =>
if chunk_eq chunk Mint64 && Archi.splitlong then
let (mv2, b3) := extract_moves nil b2 in
match b3 with
| Lstore chunk'' addr'' args'' src'' :: b4 =>
assertion (chunk_eq chunk' Mint32);
assertion (chunk_eq chunk'' Mint32);
assertion (eq_addressing addr addr');
assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr''));
assertion (check_succ s b4);
Some(BSstore2 addr addr'' args src mv1 args' src' mv2 args'' src'' s)
| _ => None
end
else (
assertion (chunk_eq chunk chunk');
assertion (eq_addressing addr addr');
assertion (check_succ s b2);
Some(BSstore chunk addr args src mv1 args' src' s))
| _ => None
end
| Icall sg ros args res s =>
let (mv1, b1) := extract_moves_ext nil b in
match b1 with
| Lcall sg' ros' :: b2 =>
let (mv2, b3) := extract_moves_ext nil b2 in
assertion (signature_eq sg sg');
assertion (check_succ s b3);
Some(BScall sg ros args res mv1 ros' mv2 s)
| _ => None
end
| Itailcall sg ros args =>
let (mv1, b1) := extract_moves_ext nil b in
match b1 with
| Ltailcall sg' ros' :: b2 =>
assertion (signature_eq sg sg');
Some(BStailcall sg ros args mv1 ros')
| _ => None
end
| Ibuiltin ef args res s =>
let (mv1, b1) := extract_moves nil b in
match b1 with
| Lbuiltin ef' args' res' :: b2 =>
let (mv2, b3) := extract_moves nil b2 in
assertion (external_function_eq ef ef');
assertion (check_succ s b3);
Some(BSbuiltin ef args res mv1 args' res' mv2 s)
| _ => None
end
| Icond cond args s1 s2 =>
let (mv1, b1) := extract_moves nil b in
match b1 with
| Lcond cond' args' s1' s2' :: b2 =>
assertion (eq_condition cond cond');
assertion (peq s1 s1');
assertion (peq s2 s2');
Some(BScond cond args mv1 args' s1 s2)
| _ => None
end
| Ijumptable arg tbl =>
let (mv1, b1) := extract_moves nil b in
match b1 with
| Ljumptable arg' tbl' :: b2 =>
assertion (list_eq_dec peq tbl tbl');
Some(BSjumptable arg mv1 arg' tbl)
| _ => None
end
| Ireturn arg =>
let (mv1, b1) := extract_moves_ext nil b in
match b1 with
| Lreturn :: b2 => Some(BSreturn arg mv1)
| _ => None
end
end.
(** Check all instructions of the RTL function [f1] against the corresponding basic blocks of LTL function [f2].  Return a map from CFG nodes to [block_shape] info. *)
Definition pair_codes (f1: RTL.function) (f2: LTL.function) : PTree.t block_shape :=
PTree.combine
(fun opti optb => do i <- opti; do b <- optb; pair_instr_block i b)
(RTL.fn_code f1) (LTL.fn_code f2).
(** Check the entry point code of the LTL function [f2].  It must be a sequence of moves that branches to the same node as the entry point of RTL function [f1]. *)
Definition pair_entrypoints (f1: RTL.function) (f2: LTL.function) : option moves :=
do b <- (LTL.fn_code f2)!(LTL.fn_entrypoint f2);
let (mv, b1) := extract_moves_ext nil b in
assertion (check_succ (RTL.fn_entrypoint f1) b1);
Some mv.
(** * Representing sets of equations between RTL registers and LTL locations. *)
(** The Rideau-Leroy validation algorithm manipulates sets of equations of the form [pseudoreg = location [kind]], meaning: - if [kind = Full], the value of [location] in the generated LTL code is the same as (or more defined than) the value of [pseudoreg] in the original RTL code; - if [kind = Low], the value of [location] in the generated LTL code is the same as (or more defined than) the low 32 bits of the 64-bit integer value of [pseudoreg] in the original RTL code; - if [kind = High], the value of [location] in the generated LTL code is the same as (or more defined than) the high 32 bits of the 64-bit integer value of [pseudoreg] in the original RTL code. *)
Inductive equation_kind : Type := Full | Low | High.
Record equation := Eq {
ekind: equation_kind;
ereg: reg;
eloc: loc
}.
(** We use AVL finite sets to represent sets of equations.  Therefore, we need total orders over equations and their components. *)
Module IndexedEqKind <: INDEXED_TYPE.
Definition t := equation_kind.
Definition index (x: t) :=
match x with Full => 1%positive | Low => 2%positive | High => 3%positive end.

(* Specifications: *)
Lemma index_inj: forall x y, index x = index y -> x = y.
Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Definition compare : forall x y : t, Compare lt eq x y.
Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Definition compare : forall x y : t, Compare lt eq x y.