(* Yoann Padioleau * * Copyright (C) 2010, University of Copenhagen DIKU and INRIA. * Copyright (C) 2006, 2007 Ecole des Mines de Nantes * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License (GPL) * version 2 as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * file license.txt for more details. *) open Common open Ast_c open Control_flow_c open Ograph_extended open Oassoc open Oassocb module Lib = Lib_parsing_c (*****************************************************************************) (* Wrappers *) (*****************************************************************************) let pr2, pr2_once = Common.mk_pr2_wrappers Flag_parsing_c.verbose_cfg (*****************************************************************************) (* todo?: compute target level with goto (but rare that different I think) * ver1: just do init, * ver2: compute depth of label (easy, intercept compound in the visitor) * * checktodo: after a switch, need check that all the st in the * compound start with a case: ? * * checktodo: how ensure that when we call aux_statement recursivly, we * pass it xi_lbl and not just auxinfo ? how enforce that ? * in fact we must either pass a xi_lbl or a newxi * * todo: can have code (and so nodes) in many places, in the size of an * array, in the init of initializer, but also in StatementExpr, ... * * todo?: steal code from CIL ? (but seems complicated ... again) *) (*****************************************************************************) (*****************************************************************************) (* Types *) (*****************************************************************************) type error = | DeadCode of Common.parse_info option | CaseNoSwitch of Common.parse_info | OnlyBreakInSwitch of Common.parse_info | WeirdSwitch of Common.parse_info | NoEnclosingLoop of Common.parse_info | GotoCantFindLabel of string * Common.parse_info | NoExit of Common.parse_info | DuplicatedLabel of string | NestedFunc | ComputedGoto | Define of Common.parse_info exception Error of error (*****************************************************************************) (* Helpers *) (*****************************************************************************) let add_node node labels nodestr g = g#add_node (Control_flow_c.mk_node node labels [] nodestr) let add_bc_node node labels parent_labels nodestr g = g#add_node (Control_flow_c.mk_node node labels parent_labels nodestr) let add_arc_opt (starti, nodei) g = starti +> do_option (fun starti -> g#add_arc ((starti, nodei), Direct)) let lbl_0 = [] let pinfo_of_ii ii = Ast_c.get_opi (List.hd ii).Ast_c.pinfo (*****************************************************************************) (* Contextual information passed in aux_statement *) (*****************************************************************************) (* Sometimes have a continue/break and we must know where we must jump. * * ctl_brace: The node list in context_info record the number of '}' at the * context point, for instance at the switch point. So that when deeper, * we can compute the difference between the number of '}' from root to * the context point to close the good number of '}' . For instance * where there is a 'continue', we must close only until the for. *) type context_info = | NoInfo | LoopInfo of nodei * nodei (* start, end *) * node list * int list | SwitchInfo of nodei * nodei (* start, end *) * node list * int list (* for the Compound case I need to do different things depending if * the compound is the compound of the function definition, the compound of * a switch, so this type allows to specify this and enable to factorize * code for the Compound *) and compound_caller = FunctionDef | Statement | Switch of (nodei -> xinfo -> xinfo) (* other information used internally in ast_to_flow and passed recursively *) and xinfo = { ctx: context_info; (* cf above *) ctx_stack: context_info list; (* are we under a ifthen[noelse]. Used for ErrorExit *) under_ifthen: bool; compound_caller: compound_caller; (* does not change recursively. Some kind of globals. *) labels_assoc: (string, nodei) oassoc; exiti: nodei option; errorexiti: nodei option; (* ctl_braces: the nodei list is to handle current imbrication depth. * It contains the must-close '}'. * update: now it is instead a node list. *) braces: node list; (* ctl: *) labels: int list; } let initial_info = { ctx = NoInfo; ctx_stack = []; under_ifthen = false; compound_caller = Statement; braces = []; labels = []; (* don't change when recurse *) labels_assoc = new oassocb []; exiti = None; errorexiti = None; } (*****************************************************************************) (* (Semi) Globals, Julia's style. *) (*****************************************************************************) (* global graph *) let g = ref (new ograph_mutable) let counter_for_labels = ref 0 let counter_for_braces = ref 0 (* For switch we use compteur too (or pass int ref) cos need know order of the * case if then later want to go from CFG to (original) AST. * update: obsolete now I think *) let counter_for_switch = ref 0 (*****************************************************************************) (* helpers *) (*****************************************************************************) (* alt: do via a todo list, so can do all in one pass (but more complex) * todo: can also count the depth level and associate it to the node, for * the ctl_braces: *) let compute_labels_and_create_them st = (* map C label to index number in graph *) let (h: (string, nodei) oassoc ref) = ref (new oassocb []) in begin st +> Visitor_c.vk_statement { Visitor_c.default_visitor_c with Visitor_c.kstatement = (fun (k, bigf) st -> match Ast_c.unwrap_st st with | Labeled (Ast_c.Label (name, _st)) -> let ii = Ast_c.get_ii_st_take_care st in (* at this point I put a lbl_0, but later I will put the * good labels. *) let s = Ast_c.str_of_name name in let newi = !g +> add_node (Label (st,name, ((),ii))) lbl_0 (s^":") in begin (* the C label already exists ? *) if (!h#haskey s) then raise (Error (DuplicatedLabel s)); h := !h#add (s, newi); (* not k _st !!! otherwise in lbl1: lbl2: i++; we miss lbl2 *) k st; end | _st -> k st ) }; !h; end (* ctl_braces: *) let insert_all_braces xs starti = xs +> List.fold_left (fun acc node -> (* Have to build a new node (clone), cos cant share it. * update: This is now done by the caller. The clones are in xs. *) let newi = !g#add_node node in !g#add_arc ((acc, newi), Direct); newi ) starti (*****************************************************************************) (* Statement *) (*****************************************************************************) (* Take in a (optional) start node, return an (optional) end node. * * history: * * ver1: old code was returning an nodei, but goto has no end, so * aux_statement should return nodei option. * * ver2: old code was taking a nodei, but should also take nodei * option. * * ver3: deadCode detection. What is dead code ? When there is no * starti to start from ? So make starti an option too ? Si on arrive * sur un label: au moment d'un deadCode, on peut verifier les * predecesseurs de ce label, auquel cas si y'en a, ca veut dire * qu'en fait c'est pas du deadCode et que donc on peut se permettre * de partir d'un starti à None. Mais si on a xx; goto far:; near: * yy; zz; far: goto near:. Bon ca doit etre un cas tres tres rare, * mais a cause de notre parcours, on va rejeter ce programme car au * moment d'arriver sur near: on n'a pas encore de predecesseurs pour * ce label. De meme, meme le cas simple ou la derniere instruction * c'est un return, alors ca va generer un DeadCode :( * * So make a first pass where dont launch exn at all. Create nodes, * if starti is None then dont add arc. Then make a second pass that * just checks that all nodes (except enter) have predecessors. * So make starti an option too. So type is now * * nodei option -> statement -> nodei option. * * todo?: if the pb is at a fake node, then try first successos that * is non fake. * * ver4: because of special needs of coccinelle, need pass more info, cf * type additionnal_info defined above. * * - to complete (break, continue (and enclosing loop), switch (and * associated case, casedefault)) we need to pass additionnal info. * The start/exit when enter in a loop, to know the current 'for'. * * - to handle the braces, need again pass additionnal info. * * - need pass the labels. * * convention: xi for the auxinfo passed recursively * *) let rec (aux_statement: (nodei option * xinfo) -> statement -> nodei option) = fun (starti, xi) stmt -> if not !Flag_parsing_c.label_strategy_2 then incr counter_for_labels; let lbl = if !Flag_parsing_c.label_strategy_2 then xi.labels else xi.labels @ [!counter_for_labels] in (* Normally the new auxinfo to pass recursively to the next aux_statement. * But in some cases we add additionnal stuff in which case we don't use * this 'xi_lbl' but a 'newxi' specially built. *) let xi_lbl = if !Flag_parsing_c.label_strategy_2 then { xi with compound_caller = Statement; } else { xi with labels = xi.labels @ [ !counter_for_labels ]; compound_caller = Statement; } in let ii = Ast_c.get_ii_st_take_care stmt in (* ------------------------- *) match Ast_c.unwrap_st stmt with (* coupling: the Switch case copy paste parts of the Compound case *) | Ast_c.Compound statxs -> (* flow_to_ast: *) let (i1, i2) = tuple_of_list2 ii in (* ctl_braces: *) incr counter_for_braces; let brace = !counter_for_braces in let s1 = "{" ^ i_to_s brace in let s2 = "}" ^ i_to_s brace in let lbl = match xi.compound_caller with | FunctionDef -> xi.labels (* share label with function header *) | Statement -> xi.labels @ [!counter_for_labels] | Switch _ -> xi.labels in let newi = !g +> add_node (SeqStart (stmt, brace, i1)) lbl s1 in let endnode = mk_node (SeqEnd (brace, i2)) lbl [] s2 in let endnode_dup = mk_fake_node (SeqEnd (brace, i2)) lbl [] s2 in (* let _endnode_dup = mk_node (SeqEnd (brace, Ast_c.fakeInfo())) lbl [] s2 in *) let newxi = { xi_lbl with braces = endnode_dup:: xi_lbl.braces } in let newxi = match xi.compound_caller with | Switch todo_in_compound -> (* note that side effect in todo_in_compound *) todo_in_compound newi newxi | FunctionDef | Statement -> newxi in !g +> add_arc_opt (starti, newi); let finishi = Some newi in aux_statement_list finishi (xi, newxi) statxs (* braces: *) +> Common.fmap (fun finishi -> (* subtil: not always return a Some. * Note that if finishi is None, alors forcement ca veut dire * qu'il y'a eu un return (ou goto), et donc forcement les * braces auront au moins ete crée une fois, et donc flow_to_ast * marchera. * Sauf si le goto revient en arriere ? mais dans ce cas * ca veut dire que le programme boucle. Pour qu'il boucle pas * il faut forcement au moins un return. *) let endi = !g#add_node endnode in if xi.compound_caller = Statement then (* Problem! This edge is only created if the block does not have return on all execution paths. *) (let afteri = !g +> add_node AfterNode lbl "[after]" in !g#add_arc ((newi, afteri), Direct); !g#add_arc ((afteri, endi), Direct)); !g#add_arc ((finishi, endi), Direct); endi ) (* ------------------------- *) | Labeled (Ast_c.Label (name, st)) -> let s = Ast_c.str_of_name name in let ilabel = xi.labels_assoc#find s in let node = mk_node (unwrap (!g#nodes#find ilabel)) lbl [] (s ^ ":") in !g#replace_node (ilabel, node); !g +> add_arc_opt (starti, ilabel); aux_statement (Some ilabel, xi_lbl) st | Jump (Ast_c.Goto name) -> let s = Ast_c.str_of_name name in (* special_cfg_ast: *) let newi = !g +> add_node (Goto (stmt, name, ((),ii))) lbl ("goto "^s^":") in !g +> add_arc_opt (starti, newi); if !Flag_parsing_c.no_gotos then Some newi else begin let ilabel = try xi.labels_assoc#find s with Not_found -> (* jump vers ErrorExit a la place ? * pourquoi tant de "cant jump" ? pas detecté par gcc ? *) raise (Error (GotoCantFindLabel (s, pinfo_of_ii ii))) in (* !g +> add_arc_opt (starti, ilabel); * todo: special_case: suppose that always goto to toplevel of * function, hence the Common.init * todo?: can perhaps report when a goto is not a classic error_goto ? * that is when it does not jump to the toplevel of the function. *) let newi = insert_all_braces (Common.list_init xi.braces) newi in !g#add_arc ((newi, ilabel), Direct); None end | Jump (Ast_c.GotoComputed e) -> raise (Error (ComputedGoto)) (* ------------------------- *) | Ast_c.ExprStatement opte -> (* flow_to_ast: old: when opte = None, then do not add in CFG. *) let s = match opte with | None -> "empty;" | Some e -> (match Ast_c.unwrap_expr e with | FunCall (e, _args) -> (match Ast_c.unwrap_expr e with | Ident namef -> Ast_c.str_of_name namef ^ "(...)" | _ -> "statement" ) | Assignment (e1, SimpleAssign, e2) -> (match Ast_c.unwrap_expr e1 with | Ident namevar -> Ast_c.str_of_name namevar ^ " = ... ;" | RecordAccess(e, field) -> (match Ast_c.unwrap_expr e with | Ident namevar -> let sfield = Ast_c.str_of_name field in Ast_c.str_of_name namevar ^ "." ^ sfield ^ " = ... ;" | _ -> "statement" ) | _ -> "statement" ) | _ -> "statement" ) in let newi = !g +> add_node (ExprStatement (stmt, (opte, ii))) lbl s in !g +> add_arc_opt (starti, newi); Some newi (* ------------------------- *) | Selection (Ast_c.If (e, st1, st2)) -> let iist2 = Ast_c.get_ii_st_take_care st2 in (match Ast_c.unwrap_st st2 with | Ast_c.ExprStatement (None) when null iist2 -> (* sometime can have ExprStatement None but it is a if-then-else, * because something like if() xx else ; * so must force to have [] in the ii associated with ExprStatement *) let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in let ii = [i1;i2;i3] in (* starti -> newi ---> newfakethen -> ... -> finalthen --> lasti * | | * |-> newfakeelse -> ... -> finalelse -| * update: there is now also a link directly to lasti. * * because of CTL, now do different things if we are in a ifthen or * ifthenelse. *) let newi = !g +> add_node (IfHeader (stmt, (e, ii))) lbl ("if") in !g +> add_arc_opt (starti, newi); let newfakethen = !g +> add_node TrueNode lbl "[then]" in let newfakeelse = !g +> add_node FallThroughNode lbl "[fallthrough]" in let afteri = !g +> add_node AfterNode lbl "[after]" in let lasti = !g +> add_node (EndStatement (Some iifakeend)) lbl "[endif]" in (* for ErrorExit heuristic *) let newxi = { xi_lbl with under_ifthen = true; } in !g#add_arc ((newi, newfakethen), Direct); !g#add_arc ((newi, newfakeelse), Direct); !g#add_arc ((newi, afteri), Direct); !g#add_arc ((afteri, lasti), Direct); !g#add_arc ((newfakeelse, lasti), Direct); let finalthen = aux_statement (Some newfakethen, newxi) st1 in !g +> add_arc_opt (finalthen, lasti); Some lasti | _unwrap_st2 -> (* starti -> newi ---> newfakethen -> ... -> finalthen --> lasti * | | * |-> newfakeelse -> ... -> finalelse -| * update: there is now also a link directly to lasti. *) let (iiheader, iielse, iifakeend) = match ii with | [i1;i2;i3;i4;i5] -> [i1;i2;i3], i4, i5 | _ -> raise (Impossible 62) in let newi = !g +> add_node (IfHeader (stmt, (e, iiheader))) lbl "if" in !g +> add_arc_opt (starti, newi); let newfakethen = !g +> add_node TrueNode lbl "[then]" in let newfakeelse = !g +> add_node FalseNode lbl "[else]" in let elsenode = !g +> add_node (Else iielse) lbl "else" in !g#add_arc ((newi, newfakethen), Direct); !g#add_arc ((newi, newfakeelse), Direct); !g#add_arc ((newfakeelse, elsenode), Direct); let finalthen = aux_statement (Some newfakethen, xi_lbl) st1 in let finalelse = aux_statement (Some elsenode, xi_lbl) st2 in (match finalthen, finalelse with | (None, None) -> None | _ -> let lasti = !g +> add_node (EndStatement(Some iifakeend)) lbl "[endif]" in let afteri = !g +> add_node AfterNode lbl "[after]" in !g#add_arc ((newi, afteri), Direct); !g#add_arc ((afteri, lasti), Direct); begin !g +> add_arc_opt (finalthen, lasti); !g +> add_arc_opt (finalelse, lasti); Some lasti end) ) (* ------------------------- *) | Selection (Ast_c.Switch (e, st)) -> let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in let ii = [i1;i2;i3] in (* The newswitchi is for the labels to know where to attach. * The newendswitch (endi) is for the 'break'. *) let newswitchi= !g +> add_node (SwitchHeader(stmt,(e,ii))) lbl "switch" in let newendswitch = !g +> add_node (EndStatement (Some iifakeend)) lbl "[endswitch]" in !g +> add_arc_opt (starti, newswitchi); (* call compound case. Need special info to pass to compound case * because we need to build a context_info that need some of the * information build inside the compound case: the nodei of { *) let finalthen = match Ast_c.unwrap_st st with | Ast_c.Compound statxs -> let statxs = Lib.stmt_elems_of_sequencable statxs in (* todo? we should not allow to match a stmt that corresponds * to a compound of a switch, so really SeqStart (stmt, ...) * here ? so maybe should change the SeqStart labeling too. * So need pass a todo_in_compound2 function. *) let todo_in_compound newi newxi = let newxi' = { newxi with ctx = SwitchInfo (newi(*!!*), newendswitch, xi.braces, lbl); ctx_stack = newxi.ctx::newxi.ctx_stack } in !g#add_arc ((newswitchi, newi), Direct); (* new: if have not a default case, then must add an edge * between start to end. * todo? except if the case[range] coverthe whole spectrum *) if not (statxs +> List.exists (fun x -> match Ast_c.unwrap_st x with | Labeled (Ast_c.Default _) -> true | _ -> false )) then begin (* when there is no default, then a valid path is * from the switchheader to the end. In between we * add a Fallthrough. *) let newafter = !g+>add_node FallThroughNode lbl "[switchfall]" in !g#add_arc ((newafter, newendswitch), Direct); !g#add_arc ((newswitchi, newafter), Direct); (* old: !g#add_arc ((newswitchi, newendswitch), Direct) +> adjust_g; *) end; newxi' in let newxi = { xi_lbl with compound_caller = (* was xi *) Switch todo_in_compound } in aux_statement (None (* no starti *), newxi) st | _x -> (* apparently gcc allows some switch body such as * switch (i) case 0 : printf("here\n"); * cf tests-bis/switch_no_body.c * but I don't think it's worthwile to handle * such pathological and rare case. Not worth * the complexity. Safe to assume a coumpound. *) raise (Error (WeirdSwitch (pinfo_of_ii [i1]))) in !g +> add_arc_opt (finalthen, newendswitch); (* what if has only returns inside. We must try to see if the * newendswitch has been used via a 'break;' or because no * 'default:') *) let res = (match finalthen with | Some finalthen -> let afteri = !g +> add_node AfterNode lbl "[after]" in !g#add_arc ((newswitchi, afteri), Direct); !g#add_arc ((afteri, newendswitch), Direct); !g#add_arc ((finalthen, newendswitch), Direct); Some newendswitch | None -> if (!g#predecessors newendswitch)#null then begin assert ((!g#successors newendswitch)#null); !g#del_node newendswitch; None end else begin let afteri = !g +> add_node AfterNode lbl "[after]" in !g#add_arc ((newswitchi, afteri), Direct); !g#add_arc ((afteri, newendswitch), Direct); Some newendswitch end ) in res | Labeled (Ast_c.Case (_, _)) | Labeled (Ast_c.CaseRange (_, _, _)) -> incr counter_for_switch; let switchrank = !counter_for_switch in let node, st = match Ast_c.get_st_and_ii stmt with | Labeled (Ast_c.Case (e, st)), ii -> (Case (stmt, (e, ii))), st | Labeled (Ast_c.CaseRange (e, e2, st)), ii -> (CaseRange (stmt, ((e, e2), ii))), st | _ -> raise (Impossible 63) in let newi = !g +> add_node node lbl "case:" in (match Common.optionise (fun () -> (* old: xi.ctx *) (xi.ctx::xi.ctx_stack) +> Common.find_some (function | SwitchInfo (a, b, c, _) -> Some (a, b, c) | _ -> None )) with | Some (startbrace, switchendi, _braces) -> (* no need to attach to previous for the first case, cos would be * redundant. *) starti +> do_option (fun starti -> if starti <> startbrace then !g +> add_arc_opt (Some starti, newi); ); let s = ("[casenode] " ^ i_to_s switchrank) in let newcasenodei = !g +> add_node (CaseNode switchrank) lbl s in !g#add_arc ((startbrace, newcasenodei), Direct); !g#add_arc ((newcasenodei, newi), Direct); | None -> raise (Error (CaseNoSwitch (pinfo_of_ii ii))) ); aux_statement (Some newi, xi_lbl) st | Labeled (Ast_c.Default st) -> incr counter_for_switch; let switchrank = !counter_for_switch in let newi = !g +> add_node (Default(stmt, ((),ii))) lbl "case default:" in !g +> add_arc_opt (starti, newi); (match xi.ctx with | SwitchInfo (startbrace, switchendi, _braces, _parent_lbl) -> let s = ("[casenode] " ^ i_to_s switchrank) in let newcasenodei = !g +> add_node (CaseNode switchrank) lbl s in !g#add_arc ((startbrace, newcasenodei), Direct); !g#add_arc ((newcasenodei, newi), Direct); | _ -> raise (Error (CaseNoSwitch (pinfo_of_ii ii))) ); aux_statement (Some newi, xi_lbl) st (* ------------------------- *) | Iteration (Ast_c.While (e, st)) -> (* starti -> newi ---> newfakethen -> ... -> finalthen - * |---|-----------------------------------| * |-> newfakelse *) let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in let ii = [i1;i2;i3] in let newi = !g +> add_node (WhileHeader (stmt, (e,ii))) lbl "while" in !g +> add_arc_opt (starti, newi); let newfakethen = !g +> add_node InLoopNode lbl "[whiletrue]" in (* let newfakeelse = !g +> add_node FalseNode lbl "[endwhile]" in *) let newafter = !g +> add_node LoopFallThroughNode lbl "[whilefall]" in let newfakeelse = !g +> add_node (EndStatement (Some iifakeend)) lbl "[endwhile]" in let newxi = { xi_lbl with ctx = LoopInfo (newi, newfakeelse, xi_lbl.braces, lbl); ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack } in !g#add_arc ((newi, newfakethen), Direct); !g#add_arc ((newafter, newfakeelse), Direct); !g#add_arc ((newi, newafter), Direct); let finalthen = aux_statement (Some newfakethen, newxi) st in !g +> add_arc_opt (finalthen, if !Flag_parsing_c.no_loops then newafter else newi); Some newfakeelse (* This time, may return None, for instance if goto in body of dowhile * (whereas While cant return None). But if return None, certainly * some deadcode. *) | Iteration (Ast_c.DoWhile (st, e)) -> (* starti -> doi ---> ... ---> finalthen (opt) ---> whiletaili * |--------- newfakethen ---------------| |---> newfakelse *) let is_zero = match Ast_c.unwrap_expr e with | Constant (Int ("0",_)) -> true | _ -> false in let (iido, iiwhiletail, iifakeend) = match ii with | [i1;i2;i3;i4;i5;i6] -> i1, [i2;i3;i4;i5], i6 | _ -> raise (Impossible 64) in let doi = !g +> add_node (DoHeader (stmt, iido)) lbl "do" in !g +> add_arc_opt (starti, doi); let taili = !g +> add_node (DoWhileTail (e, iiwhiletail)) lbl "whiletail" in (*let newfakeelse = !g +> add_node FalseNode lbl "[enddowhile]" in *) let newafter = !g +> add_node FallThroughNode lbl "[dowhilefall]" in let newfakeelse = !g +> add_node (EndStatement (Some iifakeend)) lbl "[enddowhile]" in let afteri = !g +> add_node AfterNode lbl "[after]" in !g#add_arc ((doi,afteri), Direct); !g#add_arc ((afteri,newfakeelse), Direct); let newxi = { xi_lbl with ctx = LoopInfo (taili, newfakeelse, xi_lbl.braces, lbl); ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack } in if not is_zero && (not !Flag_parsing_c.no_loops) then begin let newfakethen = !g +> add_node InLoopNode lbl "[dowhiletrue]" in !g#add_arc ((taili, newfakethen), Direct); !g#add_arc ((newfakethen, doi), Direct); end; !g#add_arc ((newafter, newfakeelse), Direct); !g#add_arc ((taili, newafter), Direct); let finalthen = aux_statement (Some doi, newxi) st in (match finalthen with | None -> if (!g#predecessors taili)#null then raise (Error (DeadCode (Some (pinfo_of_ii ii)))) else Some newfakeelse | Some finali -> !g#add_arc ((finali, taili), Direct); Some newfakeelse ) | Iteration (Ast_c.For (e1opt, e2opt, e3opt, st)) -> let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in let ii = [i1;i2;i3] in let newi = !g+>add_node(ForHeader(stmt,((e1opt,e2opt,e3opt),ii))) lbl "for" in !g +> add_arc_opt (starti, newi); let newfakethen = !g +> add_node InLoopNode lbl "[fortrue]" in (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*) let newafter = !g +> add_node LoopFallThroughNode lbl "[forfall]" in let newfakeelse = !g +> add_node (EndStatement (Some iifakeend)) lbl "[endfor]" in let newxi = { xi_lbl with ctx = LoopInfo (newi, newfakeelse, xi_lbl.braces, lbl); ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack } in !g#add_arc ((newi, newfakethen), Direct); !g#add_arc ((newafter, newfakeelse), Direct); !g#add_arc ((newi, newafter), Direct); let finalthen = aux_statement (Some newfakethen, newxi) st in !g +> add_arc_opt (finalthen, if !Flag_parsing_c.no_loops then newafter else newi); Some newfakeelse (* to generate less exception with the breakInsideLoop, analyse * correctly the loop deguisé comme list_for_each. Add a case ForMacro * in ast_c (and in lexer/parser), and then do code that imitates the * code for the For. * update: the list_for_each was previously converted into Tif by the * lexer, now they are returned as Twhile so less pbs. But not perfect. * update: now I recognize the list_for_each macro so no more problems. *) | Iteration (Ast_c.MacroIteration (s, es, st)) -> let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in let ii = [i1;i2;i3] in let newi = !g+>add_node(MacroIterHeader(stmt,((s,es),ii))) lbl "foreach" in !g +> add_arc_opt (starti, newi); let newfakethen = !g +> add_node InLoopNode lbl "[fortrue]" in (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*) let newafter = !g +> add_node LoopFallThroughNode lbl "[foreachfall]" in let newfakeelse = !g +> add_node (EndStatement (Some iifakeend)) lbl "[endforeach]" in let newxi = { xi_lbl with ctx = LoopInfo (newi, newfakeelse, xi_lbl.braces, lbl); ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack } in !g#add_arc ((newi, newfakethen), Direct); !g#add_arc ((newafter, newfakeelse), Direct); !g#add_arc ((newi, newafter), Direct); let finalthen = aux_statement (Some newfakethen, newxi) st in !g +> add_arc_opt (finalthen, if !Flag_parsing_c.no_loops then newafter else newi); Some newfakeelse (* ------------------------- *) | Jump ((Ast_c.Continue|Ast_c.Break) as x) -> let context_info = match xi.ctx with SwitchInfo (startbrace, loopendi, braces, parent_lbl) -> if x =*= Ast_c.Break then xi.ctx else (try xi.ctx_stack +> Common.find_some (function LoopInfo (_,_,_,_) as c -> Some c | _ -> None) with Not_found -> raise (Error (OnlyBreakInSwitch (pinfo_of_ii ii)))) | LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> xi.ctx | NoInfo -> raise (Error (NoEnclosingLoop (pinfo_of_ii ii))) in let parent_label = match context_info with LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> parent_lbl | SwitchInfo (startbrace, loopendi, braces, parent_lbl) -> parent_lbl | NoInfo -> raise (Impossible 65) in (* flow_to_ast: *) let (node_info, string) = let parent_string = String.concat "," (List.map string_of_int parent_label) in (match x with | Ast_c.Continue -> (Continue (stmt, ((), ii)), Printf.sprintf "continue; [%s]" parent_string) | Ast_c.Break -> (Break (stmt, ((), ii)), Printf.sprintf "break; [%s]" parent_string) | _ -> raise (Impossible 66) ) in (* idea: break or continue records the label of its parent loop or switch *) let newi = !g +> add_bc_node node_info lbl parent_label string in !g +> add_arc_opt (starti, newi); (* let newi = some starti in *) (match context_info with | LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> let desti = (match x with | Ast_c.Break -> loopendi | Ast_c.Continue -> (* if no loops, then continue behaves like break - just one iteration *) if !Flag_parsing_c.no_loops then loopendi else loopstarti | x -> raise (Impossible 67) ) in let difference = List.length xi.braces - List.length braces in assert (difference >= 0); let toend = take difference xi.braces in let newi = insert_all_braces toend newi in !g#add_arc ((newi, desti), Direct); None | SwitchInfo (startbrace, loopendi, braces, parent_lbl) -> assert (x =*= Ast_c.Break); let difference = List.length xi.braces - List.length braces in assert (difference >= 0); let toend = take difference xi.braces in let newi = insert_all_braces toend newi in !g#add_arc ((newi, loopendi), Direct); None | NoInfo -> raise (Impossible 68) ) | Jump ((Ast_c.Return | Ast_c.ReturnExpr _) as kind) -> (match xi.exiti, xi.errorexiti with | None, None -> raise (Error (NoExit (pinfo_of_ii ii))) | Some exiti, Some errorexiti -> (* flow_to_ast: *) let s = match kind with | Ast_c.Return -> "return" | Ast_c.ReturnExpr _ -> "return ..." | _ -> raise (Impossible 69) in let newi = !g +> add_node (match kind with | Ast_c.Return -> Return (stmt, ((),ii)) | Ast_c.ReturnExpr e -> ReturnExpr (stmt, (e, ii)) | _ -> raise (Impossible 70) ) lbl s in !g +> add_arc_opt (starti, newi); let newi = insert_all_braces xi.braces newi in if xi.under_ifthen then !g#add_arc ((newi, errorexiti), Direct) else !g#add_arc ((newi, exiti), Direct) ; None | _ -> raise (Impossible 71) ) (* ------------------------- *) | Ast_c.Decl decl -> let s = match decl with | (Ast_c.DeclList ([{v_namei = Some (name, _); v_type = typ; v_storage = sto}, _], _)) -> "decl:" ^ Ast_c.str_of_name name | _ -> "decl_novar_or_multivar" in let newi = !g +> add_node (Decl (decl)) lbl s in !g +> add_arc_opt (starti, newi); Some newi (* ------------------------- *) | Ast_c.Asm body -> let newi = !g +> add_node (Asm (stmt, ((body,ii)))) lbl "asm;" in !g +> add_arc_opt (starti, newi); Some newi | Ast_c.MacroStmt -> let newi = !g +> add_node (MacroStmt (stmt, ((),ii))) lbl "macro;" in !g +> add_arc_opt (starti, newi); Some newi (* ------------------------- *) | Ast_c.NestedFunc def -> raise (Error NestedFunc) and aux_statement_list starti (xi, newxi) statxs = statxs +> List.fold_left (fun starti statement_seq -> if !Flag_parsing_c.label_strategy_2 then incr counter_for_labels; let newxi' = if !Flag_parsing_c.label_strategy_2 then { newxi with labels = xi.labels @ [ !counter_for_labels ] } else newxi in match statement_seq with | Ast_c.StmtElem statement -> aux_statement (starti, newxi') statement | Ast_c.CppDirectiveStmt directive -> pr2_once ("ast_to_flow: filter a directive"); starti | Ast_c.IfdefStmt ifdef -> pr2_once ("ast_to_flow: filter a directive"); starti | Ast_c.IfdefStmt2 (ifdefs, xxs) -> let (head, body, tail) = Common.head_middle_tail ifdefs in let newi = !g +> add_node (IfdefHeader (head)) newxi'.labels "[ifdef]" in let taili = !g +> add_node (IfdefEndif (tail)) newxi'.labels "[endif]" in (* do like for a close brace, see endi.{c,cocci} *) let taili_dup = mk_fake_node (IfdefEndif (tail)) newxi'.labels [] "[endif]" in !g +> add_arc_opt (starti, newi); let elsenodes = body +> List.map (fun elseif -> let elsei = !g +> add_node (IfdefElse (elseif)) newxi'.labels "[elseif]" in !g#add_arc ((newi, elsei), Direct); elsei ) in let _finalxs = Common.zip (newi::elsenodes) xxs +> List.map (fun (start_nodei, xs)-> (* not sure if this is correct... newxi seems to relate to the assigned level number *) let newerxi = { newxi with braces = taili_dup:: newxi.braces } in let finalthen = aux_statement_list (Some start_nodei) (newxi, newerxi) xs in !g +> add_arc_opt (finalthen, taili); ) in (* This is an attempt to let a statement metavariable match this construct, but it doesn't work because #ifdef is not a statement. Not sure if this is a good or bad thing, at least if there is no else because then no statement might be there. let afteri = !g +> add_node AfterNode newxi'.labels "[after]" in !g#add_arc ((newi, afteri), Direct); !g#add_arc ((afteri, taili), Direct); *) Some taili ) starti (*****************************************************************************) (* Definition of function *) (*****************************************************************************) let (aux_definition: nodei -> definition -> unit) = fun topi funcdef -> let lbl_start = [!counter_for_labels] in let ({f_name = namefuncs; f_type = functype; f_storage= sto; f_body= compound; f_attr= attrs; f_old_c_style = oldstyle; }, ii) = funcdef in let iifunheader, iicompound = (match ii with | ioparen::icparen::iobrace::icbrace::iifake::isto -> ioparen::icparen::iifake::isto, [iobrace;icbrace] | _ -> raise (Impossible 72) ) in let topstatement = Ast_c.mk_st (Ast_c.Compound compound) iicompound in let headi = !g +> add_node (FunHeader ({ Ast_c.f_name = namefuncs; f_type = functype; f_storage = sto; f_attr = attrs; f_body = [] (* empty body *); f_old_c_style = oldstyle; }, iifunheader)) lbl_start ("function " ^ Ast_c.str_of_name namefuncs) in let enteri = !g +> add_node Enter lbl_0 "[enter]" in let exiti = !g +> add_node Exit lbl_0 "[exit]" in let errorexiti = !g +> add_node ErrorExit lbl_0 "[errorexit]" in !g#add_arc ((topi, headi), Direct); !g#add_arc ((headi, enteri), Direct); (* ---------------------------------------------------------------- *) (* todocheck: assert ? such as we have "consommer" tous les labels *) let info = { initial_info with labels = lbl_start; labels_assoc = compute_labels_and_create_them topstatement; exiti = Some exiti; errorexiti = Some errorexiti; compound_caller = FunctionDef; } in let lasti = aux_statement (Some enteri, info) topstatement in !g +> add_arc_opt (lasti, exiti) (*****************************************************************************) (* Entry point *) (*****************************************************************************) (* Helpers for SpecialDeclMacro. * * could also force the coccier to define * the toplevel macro statement as in @@ toplevel_declarator MACRO_PARAM;@@ * and so I would not need this hack and instead I would to a cleaner * match in cocci_vs_c_3.ml of a A.MacroTop vs B.MacroTop * * todo: update: now I do what I just described, so can remove this code ? *) let specialdeclmacro_to_stmt (s, args, ii) = let (iis, iiopar, iicpar, iiptvirg) = tuple_of_list4 ii in let ident = Ast_c.RegularName (s, [iis]) in let identfinal = Ast_c.mk_e (Ast_c.Ident (ident)) Ast_c.noii in let f = Ast_c.mk_e (Ast_c.FunCall (identfinal, args)) [iiopar;iicpar] in let stmt = Ast_c.mk_st (Ast_c.ExprStatement (Some f)) [iiptvirg] in stmt, (f, [iiptvirg]) let rec ast_to_control_flow e = (* globals (re)initialialisation *) g := (new ograph_mutable); counter_for_labels := 1; counter_for_braces := 0; counter_for_switch := 0; let topi = !g +> add_node TopNode lbl_0 "[top]" in match e with | Ast_c.Namespace (defs, _) -> (* todo: incorporate the other defs *) let rec loop defs = match defs with | [] -> None | def :: defs -> match ast_to_control_flow def with | None -> loop defs | x -> x in loop defs | Ast_c.Definition ((defbis,_) as def) -> let _funcs = defbis.f_name in let _c = defbis.f_body in (* if !Flag.show_misc then pr2 ("build info function " ^ funcs); *) aux_definition topi def; Some !g | Ast_c.Declaration _ | Ast_c.CppTop (Ast_c.Include _) | Ast_c.MacroTop _ -> let (elem, str) = match e with | Ast_c.Declaration decl -> (Control_flow_c.Decl decl), "decl" | Ast_c.CppTop (Ast_c.Include inc) -> (Control_flow_c.Include inc), "#include" | Ast_c.MacroTop (s, args, ii) -> let (st, (e, ii)) = specialdeclmacro_to_stmt (s, args, ii) in (Control_flow_c.ExprStatement (st, (Some e, ii))), "macrotoplevel" (*(Control_flow_c.MacroTop (s, args,ii), "macrotoplevel") *) | _ -> raise (Impossible 73) in let ei = !g +> add_node elem lbl_0 str in let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((topi, ei),Direct); !g#add_arc ((ei, endi),Direct); Some !g | Ast_c.CppTop (Ast_c.Define ((id,ii), (defkind, defval))) -> let s = match defkind with Ast_c.Undef -> "#undef " ^ id | _ -> "#define " ^ id in let headeri = !g+>add_node (DefineHeader ((id, ii), defkind)) lbl_0 s in !g#add_arc ((topi, headeri),Direct); (match defval with | Ast_c.DefineExpr e -> let ei = !g +> add_node (DefineExpr e) lbl_0 "defexpr" in let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((headeri, ei) ,Direct); !g#add_arc ((ei, endi) ,Direct); | Ast_c.DefineType ft -> let ei = !g +> add_node (DefineType ft) lbl_0 "deftyp" in let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((headeri, ei) ,Direct); !g#add_arc ((ei, endi) ,Direct); | Ast_c.DefineStmt st -> (* can have some return; inside the statement *) let exiti = !g +> add_node Exit lbl_0 "[exit]" in let errorexiti = !g +> add_node ErrorExit lbl_0 "[errorexit]" in let goto_labels = compute_labels_and_create_them st in let info = { initial_info with labels_assoc = goto_labels; exiti = Some exiti; errorexiti = Some errorexiti; } in let lasti = aux_statement (Some headeri , info) st in lasti +> do_option (fun lasti -> (* todo? if don't have a lasti ? no EndNode ? CTL will work ? *) let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((lasti, endi), Direct) ) | Ast_c.DefineDoWhileZero ((st,_e), ii) -> let goto_labels = compute_labels_and_create_them st in let info = { initial_info with labels_assoc = goto_labels } in let headerdoi = !g +> add_node (DefineDoWhileZeroHeader ((),ii)) lbl_0 "do0" in !g#add_arc ((headeri, headerdoi), Direct); let lasti = aux_statement (Some headerdoi , info) st in lasti +> do_option (fun lasti -> let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((lasti, endi), Direct) ) | Ast_c.DefineFunction def -> aux_definition headeri def; | Ast_c.DefineText (s, s_ii) -> raise (Error(Define(pinfo_of_ii ii))) | Ast_c.DefineEmpty -> let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((headeri, endi),Direct); | Ast_c.DefineInit _ -> raise (Error(Define(pinfo_of_ii ii))) | Ast_c.DefineMulti sts -> (* christia: todo *) raise (Error(Define(pinfo_of_ii ii))) | Ast_c.DefineTodo -> raise (Error(Define(pinfo_of_ii ii))) (* old: | Ast_c.DefineText (s, ii) -> let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((headeri, endi),Direct); | Ast_c.DefineInit _ -> let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((headeri, endi),Direct); | Ast_c.DefineTodo -> let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((headeri, endi),Direct); *) ); Some !g | _ -> None (*****************************************************************************) (* CFG loop annotation *) (*****************************************************************************) let annotate_loop_nodes g = let firsti = Control_flow_c.first_node g in (* just for opti a little *) let already = Hashtbl.create 101 in g +> Ograph_extended.dfs_iter_with_path firsti (fun xi path -> Hashtbl.add already xi true; let succ = g#successors xi in let succ = succ#tolist in succ +> List.iter (fun (yi,_edge) -> if Hashtbl.mem already yi && List.mem yi (xi::path) then let node = g#nodes#find yi in let ((node2, nodeinfo), nodestr) = node in let node' = ((node2, {nodeinfo with is_loop = true}), (nodestr ^ "*")) in g#replace_node (yi, node'); ); ); g (*****************************************************************************) (* CFG checks *) (*****************************************************************************) (* the second phase, deadcode detection. Old code was raising DeadCode if * lasti = None, but maybe not. In fact if have 2 return in the then * and else of an if ? * * alt: but can assert that at least there exist * a node to exiti, just check #pred of exiti. * * Why so many deadcode in Linux ? Ptet que le label est utilisé * mais dans le corps d'une macro et donc on le voit pas :( * *) let deadcode_detection g = g#nodes#iter (fun (k, node) -> let pred = g#predecessors k in if pred#null then (match unwrap node with (* old: * | Enter -> () * | EndStatement _ -> pr2 "deadcode sur fake node, pas grave"; *) | TopNode -> () | FunHeader _ -> () | ErrorExit -> () | Exit -> () (* if have 'loop: if(x) return; i++; goto loop' *) | SeqEnd _ -> () (* todo?: certaines '}' deviennent orphelins *) | x -> (match Control_flow_c.extract_fullstatement node with | Some st -> let ii = Ast_c.get_ii_st_take_care st in raise (Error (DeadCode (Some (pinfo_of_ii ii)))) | _ -> pr2 "CFG: orphelin nodes, maybe something weird happened" ) ) ) (*------------------------------------------------------------------------*) (* special_cfg_braces: the check are really specific to the way we * have build our control_flow, with the { } in the graph so normally * all those checks here are useless. * * ver1: to better error reporting, to report earlier the message, pass * the list of '{' (containing morover a brace_identifier) instead of * just the depth. *) let (check_control_flow: cflow -> unit) = fun g -> let nodes = g#nodes in let starti = first_node g in let visited = ref (new oassocb []) in let print_trace_error xs = pr2 "PB with flow:"; Common.pr2_gen xs; in let rec dfs (nodei, (* Depth depth,*) startbraces, trace) = let trace2 = nodei::trace in if !visited#haskey nodei then (* if loop back, just check that go back to a state where have same depth number *) let (*(Depth depth2)*) startbraces2 = !visited#find nodei in if (*(depth = depth2)*) startbraces <> startbraces2 then begin pr2 (sprintf "PB with flow: the node %d has not same braces count" nodei); print_trace_error trace2 end else let children = g#successors nodei in let _ = visited := !visited#add (nodei, (* Depth depth*) startbraces) in (* old: good, but detect a missing } too late, only at the end let newdepth = (match fst (nodes#find nodei) with | StartBrace i -> Depth (depth + 1) | EndBrace i -> Depth (depth - 1) | _ -> Depth depth ) in *) let newdepth = (match unwrap (nodes#find nodei), startbraces with | SeqStart (_,i,_), xs -> i::xs | SeqEnd (i,_), j::xs -> if i =|= j then xs else begin pr2 (sprintf ("PB with flow: not corresponding match between }%d and excpeted }%d at node %d") i j nodei); print_trace_error trace2; xs end | SeqEnd (i,_), [] -> pr2 (sprintf "PB with flow: too much } at }%d " i); print_trace_error trace2; [] | _, xs -> xs ) in if null children#tolist then if (* (depth = 0) *) startbraces <> [] then print_trace_error trace2 else children#tolist +> List.iter (fun (nodei,_) -> dfs (nodei, newdepth, trace2) ) in dfs (starti, (* Depth 0*) [], []) (*****************************************************************************) (* Error report *) (*****************************************************************************) let report_error error = let error_from_info info = Common.error_message_short info.file ("", info.charpos) in match error with | DeadCode infoopt -> (match infoopt with | None -> pr2 "FLOW: deadcode detected, but cant trace back the place" | Some info -> pr2 ("FLOW: deadcode detected: " ^ error_from_info info) ) | CaseNoSwitch info -> pr2 ("FLOW: case without corresponding switch: " ^ error_from_info info) | OnlyBreakInSwitch info -> pr2 ("FLOW: only break are allowed in switch: " ^ error_from_info info) | WeirdSwitch info -> pr2 ("FLOW: weird switch: " ^ error_from_info info) | NoEnclosingLoop (info) -> pr2 ("FLOW: can't find enclosing loop: " ^ error_from_info info) | GotoCantFindLabel (s, info) -> pr2 ("FLOW: cant jump to " ^ s ^ ": because we can't find this label") | NoExit info -> pr2 ("FLOW: can't find exit or error exit: " ^ error_from_info info) | DuplicatedLabel s -> pr2 ("FLOW: duplicate label " ^ s) | NestedFunc -> pr2 ("FLOW: not handling yet nested function") | ComputedGoto -> pr2 ("FLOW: not handling computed goto yet") | Define info -> pr2 ("Unsupported form of #define: " ^ error_from_info info)