(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)
(** * The dataflow analysis *)
Definition areg (ae: aenv) (r: reg) : aval := AE.get r ae.
Definition aregs (ae: aenv) (rl: list reg) : list aval := List.map (areg ae) rl.
(** Analysis of function calls.  We treat specially the case where neither the arguments nor the global variables point within the stack frame of the current function.  In this case, no pointer within the stack frame escapes during the call. *)
Definition mafter_public_call : amem := mtop.
Definition mafter_private_call (am_before: amem) : amem :=
{| am_stack := am_before.(am_stack);
am_glob := PTree.empty _;
am_nonstack := Nonstack;
am_top := plub (ab_summary (am_stack am_before)) Nonstack |}.
Definition analyze_call (am: amem) (aargs: list aval) :=
if pincl am.(am_nonstack) Nonstack
&& forallb (fun av => vpincl av Nonstack) aargs
then (Ifptr Nonstack, mafter_private_call am)
else (Vtop, mafter_public_call).
Definition transfer_call (ae: aenv) (am: amem) (args: list reg) (res: reg) :=
let (av, am') := analyze_call am (aregs ae args) in
VA.State (AE.set res av ae) am'.
(** Analysis of builtins. *)
Fixpoint abuiltin_arg (ae: aenv) (am: amem) (rm: romem) (ba: builtin_arg reg) : aval :=
match ba with
| BA r => areg ae r
| BA_int n => I n
| BA_long n => L n
| BA_float n => F n
| BA_single n => FS n
| BA_loadstack chunk ofs => loadv chunk rm am (Ptr (Stk ofs))
| BA_addrstack ofs => Ptr (Stk ofs)
| BA_loadglobal chunk id ofs => loadv chunk rm am (Ptr (Gl id ofs))
| BA_addrglobal id ofs => Ptr (Gl id ofs)
| BA_splitlong hi lo => longofwords (abuiltin_arg ae am rm hi) (abuiltin_arg ae am rm lo)
| BA_addptr ba1 ba2 =>
let v1 := abuiltin_arg ae am rm ba1 in
let v2 := abuiltin_arg ae am rm ba2 in
if Archi.ptr64 then addl v1 v2 else add v1 v2
end.
Definition set_builtin_res (br: builtin_res reg) (av: aval) (ae: aenv) : aenv :=
match br with
| BR r => AE.set r av ae
| _ => ae
end.
Definition transfer_builtin_default
(ae: aenv) (am: amem) (rm: romem)
(args: list (builtin_arg reg)) (res: builtin_res reg) :=
let (av, am') := analyze_call am (map (abuiltin_arg ae am rm) args) in
VA.State (set_builtin_res res av ae) am'.
Definition transfer_builtin
(ae: aenv) (am: amem) (rm: romem) (ef: external_function)
(args: list (builtin_arg reg)) (res: builtin_res reg) :=
match ef, args with
| EF_vload chunk, addr :: nil =>
let aaddr := abuiltin_arg ae am rm addr in
let a :=
if va_strict tt
then vlub (loadv chunk rm am aaddr) (vnormalize chunk (Ifptr Glob))
else vnormalize chunk Vtop in
VA.State (set_builtin_res res a ae) am
| EF_vstore chunk, addr :: v :: nil =>
let aaddr := abuiltin_arg ae am rm addr in
let av := abuiltin_arg ae am rm v in
let am' := storev chunk am aaddr av in
VA.State (set_builtin_res res ntop ae) (mlub am am')
| EF_memcpy sz al, dst :: src :: nil =>
let adst := abuiltin_arg ae am rm dst in
let asrc := abuiltin_arg ae am rm src in
let p := loadbytes am rm (aptr_of_aval asrc) in
let am' := storebytes am (aptr_of_aval adst) sz p in
VA.State (set_builtin_res res ntop ae) am'
| (EF_annot _ _ _ | EF_debug _ _ _), _ =>
VA.State (set_builtin_res res ntop ae) am
| EF_annot_val _ _ _, v :: nil =>
let av := abuiltin_arg ae am rm v in
VA.State (set_builtin_res res av ae) am
| _, _ =>
transfer_builtin_default ae am rm args res
end.
(** The transfer function for one instruction.  Given the abstract state "before" the instruction, computes the abstract state "after". *)
Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) : VA.t :=
match f.(fn_code)!pc with
| None =>
VA.Bot
| Some(Inop s) =>
VA.State ae am
| Some(Iop op args res s) =>
let a := eval_static_operation op (aregs ae args) in
VA.State (AE.set res a ae) am
| Some(Iload chunk addr args dst s) =>
let a := loadv chunk rm am (eval_static_addressing addr (aregs ae args)) in
VA.State (AE.set dst a ae) am
| Some(Istore chunk addr args src s) =>
let am' := storev chunk am (eval_static_addressing addr (aregs ae args)) (areg ae src) in
VA.State ae am'
| Some(Icall sig ros args res s) =>
transfer_call ae am args res
| Some(Itailcall sig ros args) =>
VA.Bot
| Some(Ibuiltin ef args res s) =>
transfer_builtin ae am rm ef args res
| Some(Icond cond args s1 s2) =>
VA.State ae am
| Some(Ijumptable arg tbl) =>
VA.State ae am
| Some(Ireturn arg) =>
VA.Bot
end.
(** A wrapper on [transfer] that removes information associated with dead registers, so as to reduce the sizes of abstract states. *)
Definition transfer' (f: function) (lastuses: PTree.t (list reg)) (rm: romem)
(pc: node) (before: VA.t) : VA.t :=
match before with
| VA.Bot => VA.Bot
| VA.State ae am =>
match transfer f rm pc ae am with
| VA.Bot => VA.Bot
| VA.State ae' am' =>
let ae'' :=
match lastuses!pc with
| None => ae'
| Some regs => eforget regs ae'
end in
VA.State ae'' am'
end
end.
(** The forward dataflow analysis. *)
Module DS := Dataflow_Solver(VA)(NodeSetForward).
Definition mfunction_entry :=
{| am_stack := ablock_init Pbot;
am_glob := PTree.empty _;
am_nonstack := Nonstack;
am_top := Nonstack |}.
Definition analyze (rm: romem) (f: function): PMap.t VA.t :=
let lu := Liveness.last_uses f in
let entry := VA.State (einit_regs f.(fn_params)) mfunction_entry in
match DS.fixpoint f.(fn_code) successors_instr (transfer' f lu rm)
f.(fn_entrypoint) entry with
| None => PMap.init (VA.State AE.top mtop)
| Some res => res
end.
(** Constructing the approximation of read-only globals *)
Definition store_init_data (ab: ablock) (p: Z) (id: init_data) : ablock :=
match id with
| Init_int8 n => ablock_store Mint8unsigned ab p (I n)
| Init_int16 n => ablock_store Mint16unsigned ab p (I n)
| Init_int32 n => ablock_store Mint32 ab p (I n)
| Init_int64 n => ablock_store Mint64 ab p (L n)
| Init_float32 n => ablock_store Mfloat32 ab p
(if propagate_float_constants tt then FS n else ntop)
| Init_float64 n => ablock_store Mfloat64 ab p
(if propagate_float_constants tt then F n else ntop)
| Init_addrof symb ofs => ablock_store Mptr ab p (Ptr (Gl symb ofs))
| Init_space n => ab
end.
Fixpoint store_init_data_list (ab: ablock) (p: Z) (idl: list init_data)
{struct idl}: ablock :=
match idl with
| nil => ab
| id :: idl' => store_init_data_list (store_init_data ab p id) (p + init_data_size id) idl'
end.
(** When CompCert is used in separate compilation mode, the [gvar_init] initializer attached to a readonly global variable may not correspond to the actual initial value of this global.  This occurs in two cases: - an [extern const] variable, which is represented by [gvar_init = nil]; - a [const] variable without an explicit initializer, which is treated by the linker as a "common" symbol, and is represented by [gvar_init = Init_space sz :: nil].  In both cases, the variable can be defined and initialized in another compilation unit which is later linked with the current compilation unit. *)
Definition definitive_initializer (init: list init_data) : bool :=
match init with
| nil => false
| Init_space _ :: nil => false
| _ => true
end.
Definition alloc_global (rm: romem) (idg: ident * globdef fundef unit): romem :=
match idg with
| (id, Gfun f) =>
PTree.remove id rm
| (id, Gvar v) =>
if v.(gvar_readonly) && negb v.(gvar_volatile) && definitive_initializer v.(gvar_init)
then PTree.set id (store_init_data_list (ablock_init Pbot) 0 v.(gvar_init)) rm
else PTree.remove id rm
end.
Definition romem_for (p: program) : romem :=
List.fold_left alloc_global p.(prog_defs) (PTree.empty _).
(** * Soundness proof *)
(** Properties of the dataflow solution. *)

(* Specifications: *)
Lemma analyze_entrypoint:
forall rm f vl m bc,
(forall v, In v vl -> vmatch bc v (Ifptr Nonstack)) ->
mmatch bc m mfunction_entry ->
exists ae am,
(analyze rm f)!!(fn_entrypoint f) = VA.State ae am
/\ ematch bc (init_regs vl (fn_params f)) ae
/\ mmatch bc m am.
Lemma analyze_successor:
forall f n ae am instr s rm ae' am',
(analyze rm f)!!n = VA.State ae am ->
f.(fn_code)!n = Some instr ->
In s (successors_instr instr) ->
transfer f rm n ae am = VA.State ae' am' ->
VA.ge (analyze rm f)!!s (transfer f rm n ae am).
Lemma analyze_succ:
forall e m rm f n ae am instr s ae' am' bc,
(analyze rm f)!!n = VA.State ae am ->
f.(fn_code)!n = Some instr ->
In s (successors_instr instr) ->
transfer f rm n ae am = VA.State ae' am' ->
ematch bc e ae' ->
mmatch bc m am' ->
exists ae'' am'',
(analyze rm f)!!s = VA.State ae'' am''
/\ ematch bc e ae''
/\ mmatch bc m am''.