Library Reloadproof

Correctness proof for the Reload pass.

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Mem.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import Conventions.
Require Import Allocproof.
Require Import LTLin.
Require Import LTLintyping.
Require Import Linear.
Require Import Parallelmove.
Require Import Reload.

Exploitation of the typing hypothesis


Reloading is applied to LTLin code that is well-typed in the sense of LTLintyping. We exploit this hypothesis to obtain information on the number of temporaries required for reloading the arguments.

Fixpoint temporaries_ok_rec (tys: list typ) (itmps ftmps: list mreg)
                            {struct tys} : bool :=
  match tys with
  | nil => true
  | Tint :: ts =>
      match itmps with
      | nil => false
      | it1 :: its => temporaries_ok_rec ts its ftmps
      end
  | Tfloat :: ts =>
      match ftmps with
      | nil => false
      | ft1 :: fts => temporaries_ok_rec ts itmps fts
      end
  end.

Definition temporaries_ok (tys: list typ) :=
  temporaries_ok_rec tys int_temporaries float_temporaries.

Remark temporaries_ok_rec_incr_1:
  forall tys it itmps ftmps,
  temporaries_ok_rec tys itmps ftmps = true ->
  temporaries_ok_rec tys (it :: itmps) ftmps = true.


Remark temporaries_ok_rec_incr_2:
  forall tys ft itmps ftmps,
  temporaries_ok_rec tys itmps ftmps = true ->
  temporaries_ok_rec tys itmps (ft :: ftmps) = true.


Remark temporaries_ok_rec_decr:
  forall tys ty itmps ftmps,
  temporaries_ok_rec (ty :: tys) itmps ftmps = true ->
  temporaries_ok_rec tys itmps ftmps = true.


Lemma temporaries_ok_enough_rec:
  forall locs itmps ftmps,
  temporaries_ok_rec (List.map Loc.type locs) itmps ftmps = true ->
  enough_temporaries_rec locs itmps ftmps = true.


Lemma temporaries_ok_enough:
  forall locs,
  temporaries_ok (List.map Loc.type locs) = true ->
  enough_temporaries locs = true.


Lemma enough_temporaries_op_args:
  forall (op: operation) (args: list loc) (res: loc),
  (List.map Loc.type args, Loc.type res) = type_of_operation op ->
  enough_temporaries args = true.


Lemma enough_temporaries_cond:
  forall (cond: condition) (args: list loc),
  List.map Loc.type args = type_of_condition cond ->
  enough_temporaries args = true.


Lemma enough_temporaries_addr:
  forall (addr: addressing) (args: list loc),
  List.map Loc.type args = type_of_addressing addr ->
  enough_temporaries args = true.


Lemma temporaries_ok_rec_length:
  forall tys itmps ftmps,
  (length tys <= length itmps)%nat ->
  (length tys <= length ftmps)%nat ->
  temporaries_ok_rec tys itmps ftmps = true.


Lemma enough_temporaries_length:
  forall args,
  (length args <= 2)%nat -> enough_temporaries args = true.


Lemma not_enough_temporaries_length:
  forall src args,
  enough_temporaries (src :: args) = false ->
  (length args >= 2)%nat.


Lemma not_enough_temporaries_addr:
  forall (ge: genv) sp addr src args ls v,
  enough_temporaries (src :: args) = false ->
  eval_addressing ge sp addr (List.map ls args) = Some v ->
  eval_operation ge sp (op_for_binary_addressing addr) (List.map ls args) = Some v.


Some additional properties of reg_for and regs_for.

Lemma regs_for_cons:
  forall src args,
  exists rsrc, exists rargs, regs_for (src :: args) = rsrc :: rargs.


Lemma reg_for_not_IT2:
  forall l, loc_acceptable l -> reg_for l <> IT2.


Correctness of the Linear constructors


This section proves theorems that establish the correctness of the Linear constructor functions such as add_move. The theorems are of the general form ``the generated Linear instructions execute and modify the location set in the expected way: the result location(s) contain the expected values; other, non-temporary locations keep their values''.

Section LINEAR_CONSTRUCTORS.

Variable ge: genv.
Variable stk: list stackframe.
Variable f: function.
Variable sp: val.

Lemma reg_for_spec:
  forall l,
  R(reg_for l) = l \/ In (R (reg_for l)) temporaries.


Lemma reg_for_diff:
  forall l l',
  Loc.diff l l' -> Loc.notin l' temporaries ->
  Loc.diff (R (reg_for l)) l'.


Lemma add_reload_correct:
  forall src dst k rs m,
  exists rs',
  star step ge (State stk f sp (add_reload src dst k) rs m)
            E0 (State stk f sp k rs' m) /\
  rs' (R dst) = rs src /\
  forall l, Loc.diff (R dst) l -> rs' l = rs l.


Lemma add_reload_correct_2:
  forall src k rs m,
  exists rs',
  star step ge (State stk f sp (add_reload src (reg_for src) k) rs m)
            E0 (State stk f sp k rs' m) /\
  rs' (R (reg_for src)) = rs src /\
  (forall l, Loc.diff (R (reg_for src)) l -> rs' l = rs l) /\
  (forall l, Loc.notin l temporaries -> rs' l = rs l).


Lemma add_spill_correct:
  forall src dst k rs m,
  exists rs',
  star step ge (State stk f sp (add_spill src dst k) rs m)
            E0 (State stk f sp k rs' m) /\
  rs' dst = rs (R src) /\
  forall l, Loc.diff dst l -> rs' l = rs l.


Lemma add_reloads_correct_rec:
  forall srcs itmps ftmps k rs m,
  enough_temporaries_rec srcs itmps ftmps = true ->
  (forall r, In (R r) srcs -> In r itmps -> False) ->
  (forall r, In (R r) srcs -> In r ftmps -> False) ->
  list_disjoint itmps ftmps ->
  list_norepet itmps ->
  list_norepet ftmps ->
  exists rs',
  star step ge
      (State stk f sp (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m)
   E0 (State stk f sp k rs' m) /\
  reglist rs' (regs_for_rec srcs itmps ftmps) = map rs srcs /\
  (forall r, ~(In r itmps) -> ~(In r ftmps) -> rs' (R r) = rs (R r)) /\
  (forall s, rs' (S s) = rs (S s)).


Lemma add_reloads_correct:
  forall srcs k rs m,
  enough_temporaries srcs = true ->
  Loc.disjoint srcs temporaries ->
  exists rs',
  star step ge (State stk f sp (add_reloads srcs (regs_for srcs) k) rs m)
            E0 (State stk f sp k rs' m) /\
  reglist rs' (regs_for srcs) = List.map rs srcs /\
  forall l, Loc.notin l temporaries -> rs' l = rs l.


Lemma add_move_correct:
  forall src dst k rs m,
  exists rs',
  star step ge (State stk f sp (add_move src dst k) rs m)
            E0 (State stk f sp k rs' m) /\
  rs' dst = rs src /\
  forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> rs' l = rs l.


Lemma effect_move_sequence:
  forall k moves rs m,
  let k' := List.fold_right (fun p k => add_move (fst p) (snd p) k) k moves in
  exists rs',
  star step ge (State stk f sp k' rs m)
            E0 (State stk f sp k rs' m) /\
  effect_seqmove moves rs rs'.


Lemma parallel_move_correct:
  forall srcs dsts k rs m,
  List.length srcs = List.length dsts ->
  Loc.no_overlap srcs dsts ->
  Loc.norepet dsts ->
  Loc.disjoint srcs temporaries ->
  Loc.disjoint dsts temporaries ->
  exists rs',
  star step ge (State stk f sp (parallel_move srcs dsts k) rs m)
               E0 (State stk f sp k rs' m) /\
  List.map rs' dsts = List.map rs srcs /\
  forall l, Loc.notin l dsts -> Loc.notin l temporaries -> rs' l = rs l.


Lemma parallel_move_arguments_correct:
  forall args sg k rs m,
  List.map Loc.type args = sg.(sig_args) ->
  locs_acceptable args ->
  exists rs',
  star step ge (State stk f sp (parallel_move args (loc_arguments sg) k) rs m)
            E0 (State stk f sp k rs' m) /\
  List.map rs' (loc_arguments sg) = List.map rs args /\
  forall l, Loc.notin l (loc_arguments sg) -> Loc.notin l temporaries -> rs' l = rs l.


Lemma parallel_move_parameters_correct:
  forall params sg k rs m,
  List.map Loc.type params = sg.(sig_args) ->
  locs_acceptable params ->
  Loc.norepet params ->
  exists rs',
  star step ge (State stk f sp (parallel_move (loc_parameters sg) params k) rs m)
            E0 (State stk f sp k rs' m) /\
  List.map rs' params = List.map rs (loc_parameters sg) /\
  forall l, Loc.notin l params -> Loc.notin l temporaries -> rs' l = rs l.


End LINEAR_CONSTRUCTORS.

Agreement between values of locations


The predicate agree states that two location maps give compatible values to all acceptable locations, that is, non-temporary registers and Local stack slots. The notion of compatibility used is the Val.lessdef ordering, which enables a Vundef value in the original program to be refined into any value in the transformed program.

A typical situation where this refinement of values occurs is at function entry point. In LTLin, all registers except those belonging to the function parameters are set to Vundef. In Linear, these registers have whatever value they had in the caller function. This difference is harmless: if the original LTLin code does not get stuck, we know that it does not use any of these Vundef values.

Definition agree (rs1 rs2: locset) : Prop :=
  forall l, loc_acceptable l -> Val.lessdef (rs1 l) (rs2 l).

Lemma agree_loc:
  forall rs1 rs2 l,
  agree rs1 rs2 -> loc_acceptable l -> Val.lessdef (rs1 l) (rs2 l).


Lemma agree_locs:
  forall rs1 rs2 ll,
  agree rs1 rs2 -> locs_acceptable ll ->
  Val.lessdef_list (map rs1 ll) (map rs2 ll).


Lemma agree_exten:
  forall rs ls1 ls2,
  agree rs ls1 ->
  (forall l, Loc.notin l temporaries -> ls2 l = ls1 l) ->
  agree rs ls2.


Lemma agree_set:
  forall rs1 rs2 rs2' l v,
  loc_acceptable l ->
  Val.lessdef v (rs2' l) ->
  (forall l', Loc.diff l l' -> Loc.notin l' temporaries -> rs2' l' = rs2 l') ->
  agree rs1 rs2 -> agree (Locmap.set l v rs1) rs2'.


Lemma agree_find_funct:
  forall (ge: Linear.genv) rs ls r f,
  Genv.find_funct ge (rs r) = Some f ->
  agree rs ls ->
  loc_acceptable r ->
  Genv.find_funct ge (ls r) = Some f.


Lemma agree_postcall_1:
  forall rs ls,
  agree rs ls ->
  agree (LTL.postcall_locs rs) ls.


Lemma agree_postcall_2:
  forall rs ls ls',
  agree (LTL.postcall_locs rs) ls ->
  (forall l,
      loc_acceptable l -> ~In l destroyed_at_call -> ~In l temporaries ->
      ls' l = ls l) ->
  agree (LTL.postcall_locs rs) ls'.


Lemma agree_postcall_call:
  forall rs ls ls' sig,
  agree rs ls ->
  (forall l,
     Loc.notin l (loc_arguments sig) -> Loc.notin l temporaries ->
     ls' l = ls l) ->
  agree (LTL.postcall_locs rs) ls'.


Lemma agree_init_locs:
  forall ls dsts vl,
  locs_acceptable dsts ->
  Loc.norepet dsts ->
  Val.lessdef_list vl (map ls dsts) ->
  agree (LTL.init_locs vl dsts) ls.


Lemma call_regs_parameters:
  forall ls sig,
  map (call_regs ls) (loc_parameters sig) = map ls (loc_arguments sig).


Lemma return_regs_preserve:
  forall ls1 ls2 l,
  ~ In l temporaries ->
  ~ In l destroyed_at_call ->
  return_regs ls1 ls2 l = ls1 l.


Lemma return_regs_arguments:
  forall ls1 ls2 sig,
  tailcall_possible sig ->
  map (return_regs ls1 ls2) (loc_arguments sig) = map ls2 (loc_arguments sig).


Lemma return_regs_result:
  forall ls1 ls2 sig,
  return_regs ls1 ls2 (R (loc_result sig)) = ls2 (R (loc_result sig)).


Preservation of labels and gotos


Lemma find_label_add_spill:
  forall lbl src dst k,
  find_label lbl (add_spill src dst k) = find_label lbl k.


Lemma find_label_add_reload:
  forall lbl src dst k,
  find_label lbl (add_reload src dst k) = find_label lbl k.


Lemma find_label_add_reloads:
  forall lbl srcs dsts k,
  find_label lbl (add_reloads srcs dsts k) = find_label lbl k.


Lemma find_label_add_move:
  forall lbl src dst k,
  find_label lbl (add_move src dst k) = find_label lbl k.


Lemma find_label_parallel_move:
  forall lbl srcs dsts k,
  find_label lbl (parallel_move srcs dsts k) = find_label lbl k.


Hint Rewrite find_label_add_spill find_label_add_reload
             find_label_add_reloads find_label_add_move
             find_label_parallel_move: labels.

Opaque reg_for.

Ltac FL := simpl; autorewrite with labels; auto.

Lemma find_label_transf_instr:
  forall lbl sg instr k,
  find_label lbl (transf_instr sg instr k) =
  if LTLin.is_label lbl instr then Some k else find_label lbl k.


Lemma find_label_transf_code:
  forall sg lbl c,
  find_label lbl (transf_code sg c) =
  option_map (transf_code sg) (LTLin.find_label lbl c).


Lemma find_label_transf_function:
  forall lbl f c,
  LTLin.find_label lbl (LTLin.fn_code f) = Some c ->
  find_label lbl (Linear.fn_code (transf_function f)) =
  Some (transf_code f c).


Semantic preservation


Section PRESERVATION.

Variable prog: LTLin.program.
Let tprog := transf_program prog.
Hypothesis WT_PROG: LTLintyping.wt_program prog.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma functions_translated:
  forall v f,
  Genv.find_funct ge v = Some f ->
  Genv.find_funct tge v = Some (transf_fundef f).
Proof (@Genv.find_funct_transf _ _ _ transf_fundef prog).

Lemma function_ptr_translated:
  forall v f,
  Genv.find_funct_ptr ge v = Some f ->
  Genv.find_funct_ptr tge v = Some (transf_fundef f).
Proof (@Genv.find_funct_ptr_transf _ _ _ transf_fundef prog).

Lemma symbols_preserved:
  forall id,
  Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof (@Genv.find_symbol_transf _ _ _ transf_fundef prog).

Lemma sig_preserved:
  forall f, funsig (transf_fundef f) = LTLin.funsig f.


Lemma find_function_wt:
  forall ros rs f,
  LTLin.find_function ge ros rs = Some f -> wt_fundef f.


The match_state predicate relates states in the original LTLin program and the transformed Linear program. The main property it enforces are:
  • Agreement between the values of locations in the two programs, according to the agree or agree_arguments predicates.
  • Agreement between the memory states of the two programs, according to the Mem.lessdef predicate.
  • Lists of LTLin instructions appearing in the source state are always suffixes of the code for the corresponding functions.
  • Well-typedness of the source code, which ensures that only acceptable locations are accessed by this code.
  • Agreement over return types during calls: the return type of a function is always equal to the return type of the signature of the corresponding call. This invariant is necessary since the conventional location used for passing return values depend on the return type. This invariant is enforced through the third parameter of the match_stackframes predicate, which is the signature of the called function.

Inductive match_stackframes:
       list LTLin.stackframe -> list Linear.stackframe -> signature -> Prop :=
  | match_stackframes_nil:
      forall sig,
      sig.(sig_res) = Some Tint ->
      match_stackframes nil nil sig
  | match_stackframes_cons:
      forall res f sp c rs s s' c' ls sig,
      match_stackframes s s' (LTLin.fn_sig f) ->
      c' = add_spill (loc_result sig) res (transf_code f c) ->
      agree (LTL.postcall_locs rs) ls ->
      loc_acceptable res ->
      wt_function f ->
      is_tail c (LTLin.fn_code f) ->
      match_stackframes
         (LTLin.Stackframe res f sp (LTL.postcall_locs rs) c :: s)
         (Linear.Stackframe (transf_function f) sp ls c' :: s')
         sig.

Inductive match_states: LTLin.state -> Linear.state -> Prop :=
  | match_states_intro:
      forall s f sp c rs m s' ls tm
        (STACKS: match_stackframes s s' (LTLin.fn_sig f))
        (AG: agree rs ls)
        (WT: wt_function f)
        (TL: is_tail c (LTLin.fn_code f))
        (MMD: Mem.lessdef m tm),
      match_states (LTLin.State s f sp c rs m)
                   (Linear.State s' (transf_function f) sp (transf_code f c) ls tm)
  | match_states_call:
      forall s f args m s' ls tm
        (STACKS: match_stackframes s s' (LTLin.funsig f))
        (AG: Val.lessdef_list args (map ls (Conventions.loc_arguments (LTLin.funsig f))))
        (PRES: forall l, ~In l temporaries -> ~In l destroyed_at_call ->
                 ls l = parent_locset s' l)
        (WT: wt_fundef f)
        (MMD: Mem.lessdef m tm),
      match_states (LTLin.Callstate s f args m)
                   (Linear.Callstate s' (transf_fundef f) ls tm)
  | match_states_return:
      forall s res m s' ls tm sig
        (STACKS: match_stackframes s s' sig)
        (AG: Val.lessdef res (ls (R (Conventions.loc_result sig))))
        (PRES: forall l, ~In l temporaries -> ~In l destroyed_at_call ->
                 ls l = parent_locset s' l)
        (MMD: Mem.lessdef m tm),
      match_states (LTLin.Returnstate s res m)
                   (Linear.Returnstate s' ls tm).

Lemma match_stackframes_change_sig:
  forall s s' sig1 sig2,
  match_stackframes s s' sig1 ->
  sig2.(sig_res) = sig1.(sig_res) ->
  match_stackframes s s' sig2.


Ltac ExploitWT :=
  match goal with
  | [ WT: wt_function _, TL: is_tail _ _ |- _ ] =>
       generalize (wt_instrs _ WT _ (is_tail_in TL)); intro WTI
  end.

The proof of semantic preservation is a simulation argument based on diagrams of the following form:
           st1 --------------- st2
            |                   |
           t|                  *|t
            |                   |
            v                   v
           st1'--------------- st2'


It is possible for the transformed code to take no transition, remaining in the same state; for instance, if the source transition corresponds to a move instruction that was eliminated. To ensure that this cannot occur infinitely often in a row, we use the following measure function that just counts the remaining number of instructions in the source code sequence.

Definition measure (st: LTLin.state) : nat :=
  match st with
  | LTLin.State s f sp c ls m => List.length c
  | LTLin.Callstate s f ls m => 0%nat
  | LTLin.Returnstate s ls m => 0%nat
  end.

Axiom ADMITTED: forall (P: Prop), P.

Theorem transf_step_correct:
  forall s1 t s2, LTLin.step ge s1 t s2 ->
  forall s1' (MS: match_states s1 s1'),
  (exists s2', plus Linear.step tge s1' t s2' /\ match_states s2 s2')
  \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat.


Lemma transf_initial_states:
  forall st1, LTLin.initial_state prog st1 ->
  exists st2, Linear.initial_state tprog st2 /\ match_states st1 st2.


Lemma transf_final_states:
  forall st1 st2 r,
  match_states st1 st2 -> LTLin.final_state st1 r -> Linear.final_state st2 r.


Theorem transf_program_correct:
  forall (beh: program_behavior), not_wrong beh ->
  LTLin.exec_program prog beh -> Linear.exec_program tprog beh.


End PRESERVATION.