AStat/frontend/tree_to_cfg.ml

669 lines
21 KiB
OCaml

(*
Cours "Sémantique et Application à la Vérification de programmes"
Antoine Miné 2015
Marc Chevalier 2018
Josselin Giet 2021
Ecole normale supérieure, Paris, France / CNRS / INRIA
*)
(*
Converts an abstract syntax tree to a control-flow-graph.
CFG arcs use a simpler language.
The conversion takes care of splitting complex statements and
expressions, and introducing temporaries if necessary.
*)
open Abstract_syntax_tree
open! Cfg
open Cfg_printer
(* map variable and function names to structures *)
module StringMap = Map.Make(String)
(* constructors *)
(* ************ *)
let node_counter = ref 0
let nodes = ref []
(* create a new node, with a fresh identifier and accumulate into nodes *)
let create_node ?(widen_target) ?(branch) (pos:position) =
incr node_counter;
let node =
{ node_id = !node_counter;
node_pos = pos;
node_in = [];
node_out = [];
branch_node = (match branch with | None -> false | Some b -> b);
widen_target = match widen_target with | None -> false | Some b -> b;
}
in
nodes := node::(!nodes);
node
let arcs = ref []
let arc_counter = ref 0
(* create a new arc and accumulate it into arcs *)
let add_arc ?(parity) (src:node) (dst:node) (inst:inst) =
incr arc_counter;
let arc =
{ arc_id = !arc_counter;
arc_src = src;
arc_dst = dst;
arc_inst = inst;
arc_parity = match parity with | None -> false | Some b -> b;
}
in
src.node_out <- arc::src.node_out;
dst.node_in <- arc::dst.node_in;
(* remember call sites for call instructions *)
(match inst with
| CFG_call f -> f.func_calls <- arc::f.func_calls
| _ -> ()
);
arcs := arc::(!arcs)
let var_counter = ref 0
(* create a variable structure, assigning it a fresh identifier *)
let create_var (name:string) (pos:extent) (typ:typ) =
incr var_counter;
{ var_id = !var_counter;
var_name = name;
var_pos = pos;
var_type = typ;
}
let fun_counter = ref 0
(* create a function structure, assigning it a fresh identifier *)
let create_fun (name:string) (entry:node) (exit:node) (pos:extent) (args:var list) (ret:var option) =
incr fun_counter;
{ func_id = !fun_counter;
func_name = name;
func_pos = pos;
func_entry = entry;
func_exit = exit;
func_args = args;
func_ret = ret;
func_calls = [];
}
(* add a sequence of instructions to the CFG between two nodes *)
let rec add_inst (entry:node) (exit:node) (l:inst ext list) =
match l with
| [] ->
(* entry --[skip]--> exit *)
add_arc entry exit (CFG_skip "skip")
| [(a,_)] ->
(* entry --[a]--> exit *)
add_arc entry exit a
| (first,x)::rest ->
(* add intermediate (next) node *)
let next = create_node (snd x) in
(* entry --[first]--> next *)
add_arc entry next first;
(* next --[rest]--> exit *)
add_inst next exit rest
(* Add a sequence of instructions to the CFG.
The entry of the first instruction is the given node; other
nodes are created.
The exit node of the last instruction is returned.
*)
let rec append_inst (entry:node) (l:inst ext list) : node =
match l with
| [] -> entry
| (first,x)::rest ->
(* add intermediate (next) node *)
let next = create_node (snd x) in
(* entry --[first]--> next *)
add_arc entry next first;
(* next --[rest]--> *)
append_inst next rest
(* Also add a sequence of instruction to the CFG.
The exist of the first instruction is given node.
The entry of the last instruction is returned.
*)
let rec prepend_inst (exit:node) (l:inst ext list) : node =
match l with
| [] -> exit
| (first,x)::rest ->
(* add intermediate (prev) node *)
let prev = create_node (fst x) in
(* prev --[first]--> exit *)
add_arc prev exit first;
(* --[rest]--> prev *)
prepend_inst prev rest
(* translation *)
(* *********** *)
(*
We need to remember a lot of information during translation, such as the
set of variables in the scope, where to jump to after a break or a return,
in which variable to store a returned value, etc.
For gotos, arcs are generated at the end of the translation of each
procedure, to handle more easily backward gotos; hence, we must also
remember label and goto instructions for this later pass.
Everything needed is wrapped in an env.
*)
type env =
{ env_vars: var StringMap.t; (* visible variables in scope, by name *)
env_funcs: func StringMap.t; (* visible functions in scope, by name *)
env_break: node option; (* destination of a break *)
env_exit: node option; (* destination of a return *)
env_return: var option; (* variable storing the returned value *)
env_allvars: VarSet.t; (* set of all variables *)
env_labels: node StringMap.t; (* labels *)
env_gotos: (node * string ext) list; (* gotos *)
}
let add_to_vars (env:env) (v:var) : env =
{ env with
env_vars = StringMap.add v.var_name v env.env_vars;
env_allvars = VarSet.add v env.env_allvars;
}
(*
Expression translation.
Also returns a list of instructions that must be executed before the
expression can be evaluated, such as function calls that have been
extracted from the expression.
*)
let rec int_expr (env:env) (expr:Abstract_syntax_tree.int_expr)
: env * inst ext list * int_expr =
match expr with
| AST_int_unary (o,(e1,_)) ->
let env1, before1, f1 = int_expr env e1 in
env1, before1, CFG_int_unary (o,f1)
| AST_int_binary (o,(e1,_),(e2,_)) ->
let env1, before1, f1 = int_expr env e1 in
let env2, before2, f2 = int_expr env1 e2 in
env2, before1@before2, CFG_int_binary (o,f1,f2)
| AST_int_identifier (id,x) ->
let var =
try StringMap.find id env.env_vars
with Not_found -> failwith (Printf.sprintf "unknown variable %s at %s" id (string_of_extent x))
in
env, [], CFG_int_var var
| AST_int_const (i,x) ->
let v =
try Z.of_string i
with _ -> failwith (Printf.sprintf "invalid integer constant %s at %s" i (string_of_extent x))
in
env, [], CFG_int_const v
| AST_int_rand ((i1,x1),(i2,x2)) ->
let v1 =
try Z.of_string i1
with _ -> failwith (Printf.sprintf "invalid integer constant %s at %s" i1 (string_of_extent x1))
and v2 =
try Z.of_string i2
with _ -> failwith (Printf.sprintf "invalid integer constant %s at %s" i2 (string_of_extent x2))
in
env, [], CFG_int_rand (v1,v2)
| AST_expr_call ((id,x),exprs) ->
let env1, inst, f = call env (id,x) exprs in
(match f.func_ret with
| None -> failwith (Printf.sprintf "function %s has no return value at %s" id (string_of_extent x))
| Some var ->
(* we must create a temporary to hold the returned value
(consider the case where the function is called twice in the expression)
*)
let tmp = create_var ("__ret_"^id) x var.var_type in
let ass = CFG_assign (tmp, CFG_int_var var) in
add_to_vars env1 var, inst@[ass,x], CFG_int_var tmp
)
and bool_expr (env:env) (expr:Abstract_syntax_tree.bool_expr)
: env * inst ext list * bool_expr =
match expr with
| AST_bool_unary (o,(e1,_)) ->
let env1, before1, f1 = bool_expr env e1 in
env1, before1, CFG_bool_unary (o,f1)
| AST_bool_binary (o,(e1,_),(e2,_)) ->
let env1, before1, f1 = bool_expr env e1 in
let env2, before2, f2 = bool_expr env1 e2 in
env2, before1@before2, CFG_bool_binary (o,f1,f2)
| AST_compare (o,(e1,_),(e2,_)) ->
let env1, before1, f1 = int_expr env e1 in
let env2, before2, f2 = int_expr env1 e2 in
env2, before1@before2, CFG_compare (o,f1,f2)
| AST_bool_const f ->
env, [], CFG_bool_const f
| AST_bool_rand ->
env, [], CFG_bool_rand
(* Translate a call. *)
and call (env:env) ((id,x):id ext) (exprs:Abstract_syntax_tree.int_expr ext list)
: env * inst ext list * func =
let f =
try StringMap.find id env.env_funcs
with Not_found -> failwith (Printf.sprintf "unknown function %s at %s" id (string_of_extent x))
in
(* match formal and actual arguments *)
let rec doargs env inst args = match args with
| [],[] -> env, inst
| var::rest1, (expr,x1)::rest2 ->
(* translate argument binding to assignment *)
let env1, before, e1 = int_expr env expr in
doargs env1 (before @ [CFG_assign (var,e1), x1] @ inst) (rest1, rest2)
| _ ->
failwith (Printf.sprintf "wrong number of arguments for function %s at %s" id (string_of_extent x))
in
let env1, inst = doargs env [CFG_call f, x] (f.func_args,exprs) in
env1, inst, f
(* Variable declarations.
Create the variable structure, remember it in the environment,
and translate initialization into assignments.
*)
let decls (env:env) (((t,_),l):var_decl) : env * inst ext list =
List.fold_left
(fun (env,inst) ((id,x),init) ->
let var = create_var id x t in
let env1 = add_to_vars env var in
let expr, ext =
match init with
| None -> AST_int_const ("0", x), x
| Some (expr,x1) -> expr, x1 in
let env2, before, e = int_expr env1 expr in
env2, before @ [CFG_assign (var,e), ext] @ inst
)
(env,[]) l
(*
Translate a statement.
Translation creates a subgraph. The first instruction of the subgraph
is connected to the given entry node, and the last is connected to the
given exit node.
*)
let rec stat (env:env) (entry:node) (exit:node) (s:stat) : env =
match s with
| AST_block l ->
let env1 = stat_list env entry exit l in
(* restore the variable scoping from the begining of the block *)
{ env1 with env_vars = env.env_vars; }
| AST_SKIP ->
add_arc entry exit (CFG_skip "skip");
env
| AST_assign ((id,x),(expr,_)) ->
(* translate expression *)
let env1, before, e1 = int_expr env expr in
(* entry --[before]--> entry1 --[assign] --> exit *)
let entry1 = append_inst entry before in
let var =
try StringMap.find id env1.env_vars
with Not_found -> failwith (Printf.sprintf "unknown variable %s at %s" id (string_of_extent x))
in
add_arc entry1 exit (CFG_assign (var, e1));
env1
| AST_increment ((id,x),v) ->
(* x++ is translated as x = x + 1 *)
let var =
try StringMap.find id env.env_vars
with Not_found -> failwith (Printf.sprintf "unknown variable %s at %s" id (string_of_extent x))
in
add_arc entry exit
(CFG_assign (var, (CFG_int_binary (AST_PLUS, CFG_int_var var, CFG_int_const (Z.of_int v)))));
env
| AST_assign_op ((id,x),op,(expr,_)) ->
(* x += expr is translated as x = x + expr *)
let env1, before, e = int_expr env expr in
let entry1 = append_inst entry before in
let var =
try StringMap.find id env1.env_vars
with Not_found -> failwith (Printf.sprintf "unknown variable %s at %s" id (string_of_extent x))
in
add_arc entry1 exit
(CFG_assign (var, (CFG_int_binary (op, CFG_int_var var, e))));
env1
| AST_assert (expr, ext) ->
(* entry --[before]--> entry1 --[assert] --> exit *)
let env1, before, e = bool_expr env expr in
let entry1 = append_inst entry before in
add_arc entry1 exit (CFG_assert (e, ext));
env1
| AST_break ((),x) ->
(* break: jump outside innermost loop *)
(* entry --[skip]--> env_break *)
(match env.env_break with
| Some node -> add_arc entry node (CFG_skip "skip: break")
| None -> failwith (Printf.sprintf "break outside loop at %s" (string_of_extent x))
);
env
| AST_return None ->
(* return: jump to the function exit *)
(* entry --[skip]--> env_exit *)
(match env.env_exit with
| Some exit -> add_arc entry exit (CFG_skip "skip: return")
| None -> failwith "no exit node for function"
);
env
| AST_return (Some (expr,x)) ->
(* return expr is translated as return = expr
the assignment is connected directly to the function exit
*)
(* entry --[before]--> entry1 --[assign] --> env_exit *)
let env1, before, e = int_expr env expr in
let entry1 = append_inst entry before in
let var =
match env1.env_return with
| Some v -> v
| None -> failwith (Printf.sprintf "function cannot return a value at %s" (string_of_extent x))
in
(match env1.env_exit with
| Some exit -> add_arc entry1 exit (CFG_assign (var, e))
| None -> failwith "no exit node for function"
);
env1
| AST_if ((expr,_),(s1,x1),(Some (s2,x2))) ->
(*
/--[expr]---> node_t --[s1]--\
entry --[before]--> entry1 --| |---> exit
\--[!expr]--> node_f --[s2]--/
*)
let env1, before, e = bool_expr env expr in
(* entry --[before]--> entry1 *)
let entry1 = append_inst entry before in
entry1.branch_node <- true;
let node_t, node_f = create_node (fst x1), create_node (fst x2) in
(* entry1 --[expr]--> node_t_t *)
add_arc ~parity:true entry1 node_t (CFG_guard e);
(* entry1 --[!expr] --> node_f *)
add_arc ~parity:false entry1 node_f (CFG_guard (CFG_bool_unary (AST_NOT, e)));
(* node_t --[s1]--> exit *)
let env2 = stat env1 node_t exit s1 in
(* node_f --[s2] --> exit *)
stat env2 node_f exit s2
| AST_if ((expr,_),(s1,x1),None) ->
(*
/--[expr]---> node_t --[s1]--\
entry --[before]--> entry1 --| |---> exit
\--[!expr]--> ---------------/
*)
let env1, before, e = bool_expr env expr in
(* entry --[before]--> entry1 *)
let entry1 = append_inst entry before in
entry1.branch_node <- true;
let node_t = create_node (fst x1) in
(* entry1 --[expr]--> node_t *)
add_arc ~parity:true entry1 node_t (CFG_guard e);
(* entry1 --[!expr]--> exit *)
add_arc ~parity:false entry1 exit (CFG_guard (CFG_bool_unary (AST_NOT, e)));
(* node_t --[s1]--> exit *)
stat env1 node_t exit s1
| AST_while ((expr,_),(s1,x1)) ->
(*
similar to "if expr then s1", except that we have
node_t --[s1]--> entry
instead of
node_t --[s1]--> exit
*)
let env1, before, e = bool_expr env expr in
(* entry --[before]--> entry1 *)
let entry1 = append_inst entry before in
entry1.branch_node <- true;
let node_t = create_node ~widen_target:true (fst x1) in
(* entry1 --[expr]--> node_t *)
add_arc ~parity:true entry1 node_t (CFG_guard e);
(* entry1 --[!expr]--> node_f *)
add_arc ~parity:false entry1 exit (CFG_guard (CFG_bool_unary (AST_NOT, e)));
(* node_t --[s1]--> entry *)
let env2 = stat { env1 with env_break = Some exit; } node_t entry s1 in
{ env2 with env_break = env1.env_break; }
| AST_for (init,expr,incr,(s1,x1)) ->
(* init *)
(* entry --[init]--> head *)
let env1, head =
if init = []
then env, entry
else (
let head = create_node (fst x1) in
stat_list env entry head init, head
)
in
(* conditional *)
(*
head --[before]--> head1 ---[expr]---> node_t
\--[!expr]--> exit
*)
let env2, before, e =
match expr with
| None -> env1, [], CFG_bool_const true
| Some (expr,_) -> bool_expr env1 expr
in
let head1 = append_inst head before in
head1.branch_node <- true;
let node_t = create_node ~widen_target:true (fst x1) in
add_arc ~parity:true head1 node_t (CFG_guard e);
add_arc ~parity:false head1 exit (CFG_guard (CFG_bool_unary (AST_NOT, e)));
(* increment *)
(* tail --[incr]--> head *)
let env3, tail =
if incr = []
then env2, head
else (
let tail = create_node (snd x1) in
stat_list env2 tail head incr, tail
)
in
(* body *)
(* node_t --[s1]--> tail *)
let env4 = stat { env3 with env_break = Some exit; } node_t tail s1 in
{ env4 with env_break = env3.env_break; }
| AST_local_decl (d,_) ->
let env1, inst = decls env d in
add_inst entry exit inst;
env1
| AST_stat_call (idx,exprs) ->
let env1, inst, _ = call env idx exprs in
add_inst entry exit inst;
env1
| AST_label (id,x) ->
(* remember the node of the label *)
if StringMap.mem id env.env_labels then
failwith (Printf.sprintf "duplicate label %s at %s" id (string_of_extent x));
add_arc entry exit (CFG_skip ("skip: label "^id));
{ env with env_labels = StringMap.add id entry env.env_labels; }
| AST_goto (id,x) ->
(* remember the goto; we will generate at the end of the function,
when all the labels are known
*)
{ env with env_gotos = (entry,(id,x))::env.env_gotos; }
(* Translate a sequence of statements. *)
and stat_list (env:env) (entry:node) (exit:node) (l:stat ext list) : env =
match l with
| [] ->
(* entry --[skip]--> exit *)
add_arc entry exit (CFG_skip "skip");
env
| [(s,_)] ->
(* entry --[s]--> exit *)
stat env entry exit s
| (first,x)::rest ->
(* add an intermediate (next) node *)
let next = create_node (snd x) in
(* entry --[first]--> next *)
let env1 = stat env entry next first in
(* next --[rest]--> exit *)
stat_list env1 next exit rest
(* Decorate a function graph with widen targets until all loops have at least one *)
let make_widen_target (e:node) =
List.iter (fun x -> if(x.node_id = e.node_id) then x.widen_target <- true) !nodes
module Widenator = struct
type color = Unseen | Opened | Visited
type state = color NodeMap.t
let get_color n st = try( NodeMap.find n !st )with Not_found -> Unseen
let rec ensure_widens n st =
st := NodeMap.add n Opened !st;
(List.iter (fun a -> match get_color a.arc_dst st with
| Opened -> if a.arc_dst.widen_target then () else (Format.printf "Warning : raw goto loop detected!@ "; make_widen_target a.arc_dst)
| _ -> ()) n.node_out);
(List.iter (fun a -> match get_color a.arc_dst st with
| Opened | Visited -> () (* already handled *)
| Unseen -> if a.arc_dst.widen_target then () else ensure_widens a.arc_dst st) n.node_out);
st := NodeMap.add n Visited !st
let widen_function f =
let r = ref NodeMap.empty in
ensure_widens f.func_entry r
end
(* Translate a function *)
let func (env:env) (f:fun_decl) : env =
(* create entry and exit nodes *)
let entry = create_node (fst f.fun_ext) in
let exit = create_node (snd f.fun_ext) in
(* create variable structures for formal arguments and return *)
let args = List.map (fun ((t,_),(id,x)) -> create_var id x t) f.fun_args in
let ret = match f.fun_typ with
| None, _ -> None
| Some t, _ -> Some (create_var ("__return_"^(fst f.fun_name)) f.fun_ext t)
in
(* create function structure *)
let func = create_fun (fst f.fun_name) entry exit f.fun_ext args ret in
(* populate env with formal arguments and return *)
let env1 =
{ env with
env_exit = Some exit;
env_return = ret;
env_funcs = StringMap.add func.func_name func env.env_funcs;
}
in
let env2 = List.fold_left add_to_vars env1 args in
let env3 = match ret with Some v -> add_to_vars env2 v | None -> env2 in
(* translate body *)
let env4 = stat_list env3 entry exit f.fun_body in
(* generate gotos *)
List.iter
(fun (src,(id,x)) ->
let dst =
try StringMap.find id env4.env_labels
with Not_found -> failwith (Printf.sprintf "unknown label %s at %s" id (string_of_extent x))
in
add_arc src dst (CFG_skip ("skip: goto "^id))
) env4.env_gotos;
(* returned environment *)
{ env with
env_funcs = env4.env_funcs;
env_allvars = env4.env_allvars;
}
(* Translate a whole program *)
let prog ((t, x): prog) : cfg =
(* initial environment *)
arcs := [];
nodes := [];
let env_init =
{ env_vars = StringMap.empty;
env_funcs = StringMap.empty;
env_break = None;
env_exit = None;
env_return = None;
env_allvars = VarSet.empty;
env_labels = StringMap.empty;
env_gotos = [];
}
in
(* translate each toplevel instruction *)
let env, revinit =
List.fold_left
(fun (env,revinit) t -> match t with
| AST_fun_decl (f,_) ->
func env f, revinit
| AST_global_decl (d,_) ->
let env1, inst1 = decls env d in
env1, List.rev_append inst1 revinit
)
(env_init,[]) t
in
let init = List.rev revinit in
(* init code *)
let entry = create_node (fst x) in
let exit = create_node (snd x) in
add_inst entry exit init;
(* extract program info *)
let vars = List.rev (VarSet.fold (fun a acc -> a::acc) env.env_allvars []) in
let funcs = List.rev (StringMap.fold (fun _ f acc -> f::acc) env.env_funcs []) in
List.iter Widenator.widen_function funcs;
{ cfg_vars = vars;
cfg_funcs = funcs;
cfg_init_entry = entry;
cfg_init_exit = exit;
cfg_nodes = List.rev !nodes;
cfg_arcs = List.rev !arcs;
}