3 * Copyright (C) 2006, 2007 Ecole des Mines de Nantes
5 * This program is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU General Public License (GPL)
7 * version 2 as published by the Free Software Foundation.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * file license.txt for more details.
23 module Lib
= Lib_parsing_c
25 (*****************************************************************************)
27 (*****************************************************************************)
28 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_parsing_c.verbose_cfg
30 (*****************************************************************************)
31 (* todo?: compute target level with goto (but rare that different I think)
33 * ver2: compute depth of label (easy, intercept compound in the visitor)
35 * checktodo: after a switch, need check that all the st in the
36 * compound start with a case: ?
38 * checktodo: how ensure that when we call aux_statement recursivly, we
39 * pass it xi_lbl and not just auxinfo ? how enforce that ?
40 * in fact we must either pass a xi_lbl or a newxi
42 * todo: can have code (and so nodes) in many places, in the size of an
43 * array, in the init of initializer, but also in StatementExpr, ...
45 * todo?: steal code from CIL ? (but seems complicated ... again) *)
46 (*****************************************************************************)
48 (*****************************************************************************)
50 (*****************************************************************************)
53 | DeadCode
of Common.parse_info
option
54 | CaseNoSwitch
of Common.parse_info
55 | OnlyBreakInSwitch
of Common.parse_info
56 | WeirdSwitch
of Common.parse_info
57 | NoEnclosingLoop
of Common.parse_info
58 | GotoCantFindLabel
of string * Common.parse_info
59 | NoExit
of Common.parse_info
60 | DuplicatedLabel
of string
63 | Define
of Common.parse_info
65 exception Error
of error
67 (*****************************************************************************)
69 (*****************************************************************************)
71 let add_node node labels nodestr g
=
72 g#
add_node (Control_flow_c.mk_node node labels
[] nodestr
)
73 let add_bc_node node labels parent_labels nodestr g
=
74 g#
add_node (Control_flow_c.mk_node node labels parent_labels nodestr
)
75 let add_arc_opt (starti
, nodei
) g
=
76 starti
+> do_option
(fun starti
-> g#add_arc
((starti
, nodei
), Direct
))
81 let pinfo_of_ii ii
= Ast_c.get_opi
(List.hd ii
).Ast_c.pinfo
85 (*****************************************************************************)
86 (* Contextual information passed in aux_statement *)
87 (*****************************************************************************)
89 (* Sometimes have a continue/break and we must know where we must jump.
91 * ctl_brace: The node list in context_info record the number of '}' at the
92 * context point, for instance at the switch point. So that when deeper,
93 * we can compute the difference between the number of '}' from root to
94 * the context point to close the good number of '}' . For instance
95 * where there is a 'continue', we must close only until the for.
99 | LoopInfo
of nodei
* nodei
(* start, end *) * node list
* int list
100 | SwitchInfo
of nodei
* nodei
(* start, end *) * node list
* int list
102 (* for the Compound case I need to do different things depending if
103 * the compound is the compound of the function definition, the compound of
104 * a switch, so this type allows to specify this and enable to factorize
105 * code for the Compound
107 and compound_caller
=
108 FunctionDef
| Statement
| Switch
of (nodei
-> xinfo
-> xinfo
)
110 (* other information used internally in ast_to_flow and passed recursively *)
113 ctx
: context_info
; (* cf above *)
114 ctx_stack
: context_info list
;
116 (* are we under a ifthen[noelse]. Used for ErrorExit *)
118 compound_caller
: compound_caller
;
120 (* does not change recursively. Some kind of globals. *)
121 labels_assoc
: (string, nodei
) oassoc
;
123 errorexiti
: nodei
option;
125 (* ctl_braces: the nodei list is to handle current imbrication depth.
126 * It contains the must-close '}'.
127 * update: now it is instead a node list.
139 under_ifthen
= false;
140 compound_caller
= Statement
;
144 (* don't change when recurse *)
145 labels_assoc
= new oassocb
[];
151 (*****************************************************************************)
152 (* (Semi) Globals, Julia's style. *)
153 (*****************************************************************************)
155 let g = ref (new ograph_mutable
)
157 let counter_for_labels = ref 0
158 let counter_for_braces = ref 0
160 (* For switch we use compteur too (or pass int ref) cos need know order of the
161 * case if then later want to go from CFG to (original) AST.
162 * update: obsolete now I think
164 let counter_for_switch = ref 0
167 (*****************************************************************************)
169 (*****************************************************************************)
171 (* alt: do via a todo list, so can do all in one pass (but more complex)
172 * todo: can also count the depth level and associate it to the node, for
175 let compute_labels_and_create_them st
=
177 (* map C label to index number in graph *)
178 let (h
: (string, nodei
) oassoc
ref) = ref (new oassocb
[]) in
181 st
+> Visitor_c.vk_statement
{ Visitor_c.default_visitor_c
with
182 Visitor_c.kstatement
= (fun (k
, bigf
) st
->
183 match Ast_c.unwrap_st st
with
184 | Labeled
(Ast_c.Label
(name
, _st
)) ->
185 let ii = Ast_c.get_ii_st_take_care st
in
186 (* at this point I put a lbl_0, but later I will put the
188 let s = Ast_c.str_of_name name
in
189 let newi = !g +> add_node (Label
(st
,name
, ((),ii))) lbl_0 (s^
":")
192 (* the C label already exists ? *)
193 if (!h#haskey
s) then raise
(Error
(DuplicatedLabel
s));
194 h
:= !h#add
(s, newi);
195 (* not k _st !!! otherwise in lbl1: lbl2: i++; we miss lbl2 *)
206 let insert_all_braces xs starti
=
207 xs
+> List.fold_left
(fun acc node
->
208 (* Have to build a new node (clone), cos cant share it.
209 * update: This is now done by the caller. The clones are in xs.
211 let newi = !g#
add_node node
in
212 !g#add_arc
((acc
, newi), Direct
);
216 (*****************************************************************************)
218 (*****************************************************************************)
220 (* Take in a (optional) start node, return an (optional) end node.
224 * ver1: old code was returning an nodei, but goto has no end, so
225 * aux_statement should return nodei option.
227 * ver2: old code was taking a nodei, but should also take nodei
230 * ver3: deadCode detection. What is dead code ? When there is no
231 * starti to start from ? So make starti an option too ? Si on arrive
232 * sur un label: au moment d'un deadCode, on peut verifier les
233 * predecesseurs de ce label, auquel cas si y'en a, ca veut dire
234 * qu'en fait c'est pas du deadCode et que donc on peut se permettre
235 * de partir d'un starti à None. Mais si on a xx; goto far:; near:
236 * yy; zz; far: goto near:. Bon ca doit etre un cas tres tres rare,
237 * mais a cause de notre parcours, on va rejeter ce programme car au
238 * moment d'arriver sur near: on n'a pas encore de predecesseurs pour
239 * ce label. De meme, meme le cas simple ou la derniere instruction
240 * c'est un return, alors ca va generer un DeadCode :(
242 * So make a first pass where dont launch exn at all. Create nodes,
243 * if starti is None then dont add arc. Then make a second pass that
244 * just checks that all nodes (except enter) have predecessors.
245 * So make starti an option too. So type is now
247 * nodei option -> statement -> nodei option.
249 * todo?: if the pb is at a fake node, then try first successos that
252 * ver4: because of special needs of coccinelle, need pass more info, cf
253 * type additionnal_info defined above.
255 * - to complete (break, continue (and enclosing loop), switch (and
256 * associated case, casedefault)) we need to pass additionnal info.
257 * The start/exit when enter in a loop, to know the current 'for'.
259 * - to handle the braces, need again pass additionnal info.
261 * - need pass the labels.
263 * convention: xi for the auxinfo passed recursively
267 let rec (aux_statement
: (nodei
option * xinfo
) -> statement
-> nodei
option) =
268 fun (starti
, xi
) stmt
->
270 if not
!Flag_parsing_c.label_strategy_2
271 then incr
counter_for_labels;
274 if !Flag_parsing_c.label_strategy_2
276 else xi
.labels
@ [!counter_for_labels]
279 (* Normally the new auxinfo to pass recursively to the next aux_statement.
280 * But in some cases we add additionnal stuff in which case we don't use
281 * this 'xi_lbl' but a 'newxi' specially built.
284 if !Flag_parsing_c.label_strategy_2
286 compound_caller
= Statement
;
289 labels
= xi
.labels
@ [ !counter_for_labels ];
290 compound_caller
= Statement
;
293 let ii = Ast_c.get_ii_st_take_care stmt
in
295 (* ------------------------- *)
296 match Ast_c.unwrap_st stmt
with
298 (* coupling: the Switch case copy paste parts of the Compound case *)
299 | Ast_c.Compound statxs
->
301 let (i1
, i2
) = tuple_of_list2
ii in
304 incr
counter_for_braces;
305 let brace = !counter_for_braces in
307 let s1 = "{" ^ i_to_s
brace in
308 let s2 = "}" ^ i_to_s
brace in
310 let lbl = match xi
.compound_caller
with
311 | FunctionDef
-> xi
.labels
(* share label with function header *)
312 | Statement
-> xi
.labels
@ [!counter_for_labels]
313 | Switch _
-> xi
.labels
316 let newi = !g +> add_node (SeqStart
(stmt
, brace, i1
)) lbl s1 in
317 let endnode = mk_node
(SeqEnd
(brace, i2
)) lbl [] s2 in
318 let endnode_dup = mk_fake_node
(SeqEnd
(brace, i2
)) lbl [] s2 in
321 mk_node (SeqEnd (brace, Ast_c.fakeInfo())) lbl [] s2 in
324 let newxi = { xi_lbl with braces
= endnode_dup:: xi_lbl.braces
} in
326 let newxi = match xi
.compound_caller
with
327 | Switch todo_in_compound
->
328 (* note that side effect in todo_in_compound *)
329 todo_in_compound
newi newxi
330 | FunctionDef
| Statement
-> newxi
333 !g +> add_arc_opt (starti
, newi);
334 let starti = Some
newi in
336 aux_statement_list
starti (xi
, newxi) statxs
339 +> Common.fmap
(fun starti ->
340 (* subtil: not always return a Some.
341 * Note that if starti is None, alors forcement ca veut dire
342 * qu'il y'a eu un return (ou goto), et donc forcement les
343 * braces auront au moins ete crée une fois, et donc flow_to_ast
345 * Sauf si le goto revient en arriere ? mais dans ce cas
346 * ca veut dire que le programme boucle. Pour qu'il boucle pas
347 * il faut forcement au moins un return.
349 let endi = !g#
add_node endnode in
350 !g#add_arc
((starti, endi), Direct
);
355 (* ------------------------- *)
356 | Labeled
(Ast_c.Label
(name
, st
)) ->
357 let s = Ast_c.str_of_name name
in
358 let ilabel = xi
.labels_assoc#find
s in
359 let node = mk_node
(unwrap
(!g#nodes#find
ilabel)) lbl [] (s ^
":") in
360 !g#replace_node
(ilabel, node);
361 !g +> add_arc_opt (starti, ilabel);
362 aux_statement
(Some
ilabel, xi_lbl) st
365 | Jump
(Ast_c.Goto name
) ->
366 let s = Ast_c.str_of_name name
in
367 (* special_cfg_ast: *)
368 let newi = !g +> add_node (Goto
(stmt
, name
, ((),ii))) lbl ("goto "^
s^
":")
370 !g +> add_arc_opt (starti, newi);
373 try xi
.labels_assoc#find
s
375 (* jump vers ErrorExit a la place ?
376 * pourquoi tant de "cant jump" ? pas detecté par gcc ?
378 raise
(Error
(GotoCantFindLabel
(s, pinfo_of_ii ii)))
380 (* !g +> add_arc_opt (starti, ilabel);
381 * todo: special_case: suppose that always goto to toplevel of function,
382 * hence the Common.init
383 * todo?: can perhaps report when a goto is not a classic error_goto ?
384 * that is when it does not jump to the toplevel of the function.
386 let newi = insert_all_braces (Common.list_init xi
.braces
) newi in
387 !g#add_arc
((newi, ilabel), Direct
);
390 | Jump
(Ast_c.GotoComputed e
) ->
391 raise
(Error
(ComputedGoto
))
393 (* ------------------------- *)
394 | Ast_c.ExprStatement opte
->
395 (* flow_to_ast: old: when opte = None, then do not add in CFG. *)
400 (match Ast_c.unwrap_expr e
with
401 | FunCall
(e
, _args
) ->
402 (match Ast_c.unwrap_expr e
with
404 Ast_c.str_of_name namef ^
"(...)"
407 | Assignment
(e1
, SimpleAssign
, e2
) ->
408 (match Ast_c.unwrap_expr e1
with
410 Ast_c.str_of_name namevar ^
" = ... ;"
411 | RecordAccess
(e
, field
) ->
412 (match Ast_c.unwrap_expr e
with
414 let sfield = Ast_c.str_of_name field
in
415 Ast_c.str_of_name namevar ^
"." ^
sfield ^
" = ... ;"
423 let newi = !g +> add_node (ExprStatement
(stmt
, (opte
, ii))) lbl s in
424 !g +> add_arc_opt (starti, newi);
428 (* ------------------------- *)
429 | Selection
(Ast_c.If
(e
, st1
, st2
)) ->
431 let iist2 = Ast_c.get_ii_st_take_care st2
in
432 (match Ast_c.unwrap_st st2
with
433 | Ast_c.ExprStatement
(None
) when null
iist2 ->
434 (* sometome can have ExprStatement None but it is a if-then-else,
435 * because something like if() xx else ;
436 * so must force to have [] in the ii associated with ExprStatement
439 let (i1
,i2
,i3
, iifakeend
) = tuple_of_list4
ii in
440 let ii = [i1
;i2
;i3
] in
441 (* starti -> newi ---> newfakethen -> ... -> finalthen --> lasti
443 * |-> newfakeelse -> ... -> finalelse -|
444 * update: there is now also a link directly to lasti.
446 * because of CTL, now do different things if we are in a ifthen or
449 let newi = !g +> add_node (IfHeader
(stmt
, (e
, ii))) lbl ("if") in
450 !g +> add_arc_opt (starti, newi);
451 let newfakethen = !g +> add_node TrueNode
lbl "[then]" in
452 let newfakeelse = !g +> add_node FallThroughNode
lbl "[fallthrough]" in
453 let afteri = !g +> add_node AfterNode
lbl "[after]" in
454 let lasti = !g +> add_node (EndStatement
(Some iifakeend
)) lbl "[endif]"
457 (* for ErrorExit heuristic *)
458 let newxi = { xi_lbl with under_ifthen
= true; } in
460 !g#add_arc
((newi, newfakethen), Direct
);
461 !g#add_arc
((newi, newfakeelse), Direct
);
462 !g#add_arc
((newi, afteri), Direct
);
463 !g#add_arc
((afteri, lasti), Direct
);
464 !g#add_arc
((newfakeelse, lasti), Direct
);
466 let finalthen = aux_statement
(Some
newfakethen, newxi) st1
in
467 !g +> add_arc_opt (finalthen, lasti);
471 (* starti -> newi ---> newfakethen -> ... -> finalthen --> lasti
473 * |-> newfakeelse -> ... -> finalelse -|
474 * update: there is now also a link directly to lasti.
476 let (iiheader
, iielse
, iifakeend
) =
478 | [i1
;i2
;i3
;i4
;i5
] -> [i1
;i2
;i3
], i4
, i5
479 | _
-> raise Impossible
481 let newi = !g +> add_node (IfHeader
(stmt
, (e
, iiheader
))) lbl "if" in
482 !g +> add_arc_opt (starti, newi);
483 let newfakethen = !g +> add_node TrueNode
lbl "[then]" in
484 let newfakeelse = !g +> add_node FalseNode
lbl "[else]" in
485 let elsenode = !g +> add_node (Else iielse
) lbl "else" in
488 !g#add_arc
((newi, newfakethen), Direct
);
489 !g#add_arc
((newi, newfakeelse), Direct
);
491 !g#add_arc
((newfakeelse, elsenode), Direct
);
493 let finalthen = aux_statement
(Some
newfakethen, xi_lbl) st1
in
494 let finalelse = aux_statement
(Some
elsenode, xi_lbl) st2
in
496 (match finalthen, finalelse with
497 | (None
, None
) -> None
500 !g +> add_node (EndStatement
(Some iifakeend
)) lbl "[endif]" in
502 !g +> add_node AfterNode
lbl "[after]" in
503 !g#add_arc
((newi, afteri), Direct
);
504 !g#add_arc
((afteri, lasti), Direct
);
506 !g +> add_arc_opt (finalthen, lasti);
507 !g +> add_arc_opt (finalelse, lasti);
512 (* ------------------------- *)
513 | Selection
(Ast_c.Switch
(e
, st
)) ->
514 let (i1
,i2
,i3
, iifakeend
) = tuple_of_list4
ii in
515 let ii = [i1
;i2
;i3
] in
517 (* The newswitchi is for the labels to know where to attach.
518 * The newendswitch (endi) is for the 'break'. *)
520 !g+> add_node (SwitchHeader
(stmt
,(e
,ii))) lbl "switch" in
522 !g +> add_node (EndStatement
(Some iifakeend
)) lbl "[endswitch]" in
524 !g +> add_arc_opt (starti, newswitchi);
526 (* call compound case. Need special info to pass to compound case
527 * because we need to build a context_info that need some of the
528 * information build inside the compound case: the nodei of {
531 match Ast_c.unwrap_st st
with
532 | Ast_c.Compound statxs
->
534 let statxs = Lib.stmt_elems_of_sequencable
statxs in
536 (* todo? we should not allow to match a stmt that corresponds
537 * to a compound of a switch, so really SeqStart (stmt, ...)
538 * here ? so maybe should change the SeqStart labeling too.
539 * So need pass a todo_in_compound2 function.
541 let todo_in_compound newi newxi =
542 let newxi'
= { newxi with
543 ctx
= SwitchInfo
(newi(*!!*), newendswitch, xi
.braces
, lbl);
544 ctx_stack
= newxi.ctx
::newxi.ctx_stack
547 !g#add_arc
((newswitchi, newi), Direct
);
548 (* new: if have not a default case, then must add an edge
549 * between start to end.
550 * todo? except if the case[range] coverthe whole spectrum
552 if not
(statxs +> List.exists
(fun x
->
553 match Ast_c.unwrap_st x
with
554 | Labeled
(Ast_c.Default _
) -> true
558 (* when there is no default, then a valid path is
559 * from the switchheader to the end. In between we
563 let newafter = !g+>add_node FallThroughNode
lbl "[switchfall]"
565 !g#add_arc
((newafter, newendswitch), Direct
);
566 !g#add_arc
((newswitchi, newafter), Direct
);
568 !g#add_arc ((newswitchi, newendswitch), Direct) +> adjust_g;
573 let newxi = { xi
with compound_caller
=
574 Switch
todo_in_compound
577 aux_statement
(None
(* no starti *), newxi) st
579 (* apparently gcc allows some switch body such as
580 * switch (i) case 0 : printf("here\n");
581 * cf tests-bis/switch_no_body.c
582 * but I don't think it's worthwile to handle
583 * such pathological and rare case. Not worth
584 * the complexity. Safe to assume a coumpound.
586 raise
(Error
(WeirdSwitch
(pinfo_of_ii [i1
])))
588 !g +> add_arc_opt (finalthen, newendswitch);
591 (* what if has only returns inside. We must try to see if the
592 * newendswitch has been used via a 'break;' or because no
596 (match finalthen with
599 let afteri = !g +> add_node AfterNode
lbl "[after]" in
600 !g#add_arc
((newswitchi, afteri), Direct
);
601 !g#add_arc
((afteri, newendswitch), Direct
);
604 !g#add_arc
((finalthen, newendswitch), Direct
);
607 if (!g#predecessors
newendswitch)#null
609 assert ((!g#successors
newendswitch)#null
);
610 !g#del_node
newendswitch;
615 let afteri = !g +> add_node AfterNode
lbl "[after]" in
616 !g#add_arc
((newswitchi, afteri), Direct
);
617 !g#add_arc
((afteri, newendswitch), Direct
);
627 | Labeled
(Ast_c.Case
(_
, _
))
628 | Labeled
(Ast_c.CaseRange
(_
, _
, _
)) ->
630 incr
counter_for_switch;
631 let switchrank = !counter_for_switch in
633 match Ast_c.get_st_and_ii stmt
with
634 | Labeled
(Ast_c.Case
(e
, st
)), ii ->
635 (Case
(stmt
, (e
, ii))), st
636 | Labeled
(Ast_c.CaseRange
(e
, e2
, st
)), ii ->
637 (CaseRange
(stmt
, ((e
, e2
), ii))), st
638 | _
-> raise Impossible
641 let newi = !g +> add_node node lbl "case:" in
643 (match Common.optionise
(fun () ->
645 (xi
.ctx
::xi
.ctx_stack
) +> Common.find_some
(function
646 | SwitchInfo
(a
, b
, c
, _
) -> Some
(a
, b
, c
)
650 | Some
(startbrace
, switchendi
, _braces
) ->
651 (* no need to attach to previous for the first case, cos would be
653 starti +> do_option
(fun starti ->
654 if starti <> startbrace
655 then !g +> add_arc_opt (Some
starti, newi);
658 let s = ("[casenode] " ^ i_to_s
switchrank) in
659 let newcasenodei = !g +> add_node (CaseNode
switchrank) lbl s in
660 !g#add_arc
((startbrace
, newcasenodei), Direct
);
661 !g#add_arc
((newcasenodei, newi), Direct
);
662 | None
-> raise
(Error
(CaseNoSwitch
(pinfo_of_ii ii)))
664 aux_statement
(Some
newi, xi_lbl) st
667 | Labeled
(Ast_c.Default st
) ->
668 incr
counter_for_switch;
669 let switchrank = !counter_for_switch in
671 let newi = !g +> add_node (Default
(stmt
, ((),ii))) lbl "case default:" in
672 !g +> add_arc_opt (starti, newi);
675 | SwitchInfo
(startbrace
, switchendi
, _braces
, _parent_lbl
) ->
676 let s = ("[casenode] " ^ i_to_s
switchrank) in
677 let newcasenodei = !g +> add_node (CaseNode
switchrank) lbl s in
678 !g#add_arc
((startbrace
, newcasenodei), Direct
);
679 !g#add_arc
((newcasenodei, newi), Direct
);
680 | _
-> raise
(Error
(CaseNoSwitch
(pinfo_of_ii ii)))
682 aux_statement
(Some
newi, xi_lbl) st
689 (* ------------------------- *)
690 | Iteration
(Ast_c.While
(e
, st
)) ->
691 (* starti -> newi ---> newfakethen -> ... -> finalthen -
692 * |---|-----------------------------------|
696 let (i1
,i2
,i3
, iifakeend
) = tuple_of_list4
ii in
697 let ii = [i1
;i2
;i3
] in
699 let newi = !g +> add_node (WhileHeader
(stmt
, (e
,ii))) lbl "while" in
700 !g +> add_arc_opt (starti, newi);
701 let newfakethen = !g +> add_node InLoopNode
lbl "[whiletrue]" in
702 (* let newfakeelse = !g +> add_node FalseNode lbl "[endwhile]" in *)
703 let newafter = !g +> add_node FallThroughNode
lbl "[whilefall]" in
705 !g +> add_node (EndStatement
(Some iifakeend
)) lbl "[endwhile]" in
707 let newxi = { xi_lbl with
708 ctx
= LoopInfo
(newi, newfakeelse, xi_lbl.braces
, lbl);
709 ctx_stack
= xi_lbl.ctx
::xi_lbl.ctx_stack
713 !g#add_arc
((newi, newfakethen), Direct
);
714 !g#add_arc
((newafter, newfakeelse), Direct
);
715 !g#add_arc
((newi, newafter), Direct
);
716 let finalthen = aux_statement
(Some
newfakethen, newxi) st
in
717 !g +> add_arc_opt (finalthen, newi);
721 (* This time, may return None, for instance if goto in body of dowhile
722 * (whereas While cant return None). But if return None, certainly
725 | Iteration
(Ast_c.DoWhile
(st
, e
)) ->
726 (* starti -> doi ---> ... ---> finalthen (opt) ---> whiletaili
727 * |--------- newfakethen ---------------| |---> newfakelse
730 match Ast_c.unwrap_expr e
with
731 | Constant
(Int
("0",_
)) -> true
735 let (iido
, iiwhiletail
, iifakeend
) =
737 | [i1
;i2
;i3
;i4
;i5
;i6
] -> i1
, [i2
;i3
;i4
;i5
], i6
738 | _
-> raise Impossible
740 let doi = !g +> add_node (DoHeader
(stmt
, iido
)) lbl "do" in
741 !g +> add_arc_opt (starti, doi);
742 let taili = !g +> add_node (DoWhileTail
(e
, iiwhiletail
)) lbl "whiletail"
746 (*let newfakeelse = !g +> add_node FalseNode lbl "[enddowhile]" in *)
747 let newafter = !g +> add_node FallThroughNode
lbl "[dowhilefall]" in
749 !g +> add_node (EndStatement
(Some iifakeend
)) lbl "[enddowhile]" in
751 let newxi = { xi_lbl with
752 ctx
= LoopInfo
(taili, newfakeelse, xi_lbl.braces
, lbl);
753 ctx_stack
= xi_lbl.ctx
::xi_lbl.ctx_stack
759 let newfakethen = !g +> add_node InLoopNode
lbl "[dowhiletrue]" in
760 !g#add_arc
((taili, newfakethen), Direct
);
761 !g#add_arc
((newfakethen, doi), Direct
);
764 !g#add_arc
((newafter, newfakeelse), Direct
);
765 !g#add_arc
((taili, newafter), Direct
);
768 let finalthen = aux_statement
(Some
doi, newxi) st
in
769 (match finalthen with
771 if (!g#predecessors
taili)#null
772 then raise
(Error
(DeadCode
(Some
(pinfo_of_ii ii))))
773 else Some
newfakeelse
775 !g#add_arc
((finali
, taili), Direct
);
781 | Iteration
(Ast_c.For
(e1opt
, e2opt
, e3opt
, st
)) ->
782 let (i1
,i2
,i3
, iifakeend
) = tuple_of_list4
ii in
783 let ii = [i1
;i2
;i3
] in
786 !g+>add_node(ForHeader
(stmt
,((e1opt
,e2opt
,e3opt
),ii))) lbl "for" in
787 !g +> add_arc_opt (starti, newi);
788 let newfakethen = !g +> add_node InLoopNode
lbl "[fortrue]" in
789 (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*)
790 let newafter = !g +> add_node FallThroughNode
lbl "[forfall]" in
792 !g +> add_node (EndStatement
(Some iifakeend
)) lbl "[endfor]" in
794 let newxi = { xi_lbl with
795 ctx
= LoopInfo
(newi, newfakeelse, xi_lbl.braces
, lbl);
796 ctx_stack
= xi_lbl.ctx
::xi_lbl.ctx_stack
800 !g#add_arc
((newi, newfakethen), Direct
);
801 !g#add_arc
((newafter, newfakeelse), Direct
);
802 !g#add_arc
((newi, newafter), Direct
);
803 let finalthen = aux_statement
(Some
newfakethen, newxi) st
in
804 !g +> add_arc_opt (finalthen, newi);
808 (* to generate less exception with the breakInsideLoop, analyse
809 * correctly the loop deguisé comme list_for_each. Add a case ForMacro
810 * in ast_c (and in lexer/parser), and then do code that imitates the
812 * update: the list_for_each was previously converted into Tif by the
813 * lexer, now they are returned as Twhile so less pbs. But not perfect.
814 * update: now I recognize the list_for_each macro so no more problems.
816 | Iteration
(Ast_c.MacroIteration
(s, es
, st
)) ->
817 let (i1
,i2
,i3
, iifakeend
) = tuple_of_list4
ii in
818 let ii = [i1
;i2
;i3
] in
821 !g+>add_node(MacroIterHeader
(stmt
,((s,es
),ii))) lbl "foreach" in
822 !g +> add_arc_opt (starti, newi);
823 let newfakethen = !g +> add_node InLoopNode
lbl "[fortrue]" in
824 (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*)
825 let newafter = !g +> add_node FallThroughNode
lbl "[foreachfall]" in
827 !g +> add_node (EndStatement
(Some iifakeend
)) lbl "[endforeach]" in
829 let newxi = { xi_lbl with
830 ctx
= LoopInfo
(newi, newfakeelse, xi_lbl.braces
, lbl);
831 ctx_stack
= xi_lbl.ctx
::xi_lbl.ctx_stack
835 !g#add_arc
((newi, newfakethen), Direct
);
836 !g#add_arc
((newafter, newfakeelse), Direct
);
837 !g#add_arc
((newi, newafter), Direct
);
838 let finalthen = aux_statement
(Some
newfakethen, newxi) st
in
839 !g +> add_arc_opt (finalthen, newi);
844 (* ------------------------- *)
845 | Jump
((Ast_c.Continue
|Ast_c.Break
) as x
) ->
848 SwitchInfo
(startbrace
, loopendi
, braces
, parent_lbl
) ->
853 xi
.ctx_stack
+> Common.find_some
(function
854 LoopInfo
(_
,_
,_
,_
) as c
-> Some c
857 raise
(Error
(OnlyBreakInSwitch
(pinfo_of_ii ii))))
858 | LoopInfo
(loopstarti
, loopendi
, braces
, parent_lbl
) -> xi
.ctx
859 | NoInfo
-> raise
(Error
(NoEnclosingLoop
(pinfo_of_ii ii))) in
862 match context_info with
863 LoopInfo
(loopstarti
, loopendi
, braces
, parent_lbl
) -> parent_lbl
864 | SwitchInfo
(startbrace
, loopendi
, braces
, parent_lbl
) -> parent_lbl
865 | NoInfo
-> raise Impossible
in
868 let (node_info
, string) =
870 String.concat
"," (List.map string_of_int
parent_label) in
873 (Continue
(stmt
, ((), ii)),
874 Printf.sprintf
"continue; [%s]" parent_string)
876 (Break
(stmt
, ((), ii)),
877 Printf.sprintf
"break; [%s]" parent_string)
878 | _
-> raise Impossible
881 (* idea: break or continue records the label of its parent loop or
883 let newi = !g +> add_bc_node node_info
lbl parent_label string in
884 !g +> add_arc_opt (starti, newi);
886 (* let newi = some starti in *)
888 (match context_info with
889 | LoopInfo
(loopstarti
, loopendi
, braces
, parent_lbl
) ->
892 | Ast_c.Break
-> loopendi
893 | Ast_c.Continue
-> loopstarti
894 | x
-> raise Impossible
896 let difference = List.length xi
.braces
- List.length braces
in
897 assert (difference >= 0);
898 let toend = take
difference xi
.braces
in
899 let newi = insert_all_braces toend newi in
900 !g#add_arc
((newi, desti), Direct
);
903 | SwitchInfo
(startbrace
, loopendi
, braces
, parent_lbl
) ->
904 assert (x
=*= Ast_c.Break
);
905 let difference = List.length xi
.braces
- List.length braces
in
906 assert (difference >= 0);
907 let toend = take
difference xi
.braces
in
908 let newi = insert_all_braces toend newi in
909 !g#add_arc
((newi, loopendi
), Direct
);
911 | NoInfo
-> raise Impossible
914 | Jump
((Ast_c.Return
| Ast_c.ReturnExpr _
) as kind
) ->
915 (match xi
.exiti
, xi
.errorexiti
with
916 | None
, None
-> raise
(Error
(NoExit
(pinfo_of_ii ii)))
917 | Some exiti
, Some errorexiti
->
922 | Ast_c.Return
-> "return"
923 | Ast_c.ReturnExpr _
-> "return ..."
924 | _
-> raise Impossible
929 | Ast_c.Return
-> Return
(stmt
, ((),ii))
930 | Ast_c.ReturnExpr e
-> ReturnExpr
(stmt
, (e
, ii))
931 | _
-> raise Impossible
935 !g +> add_arc_opt (starti, newi);
936 let newi = insert_all_braces xi
.braces
newi in
939 then !g#add_arc
((newi, errorexiti
), Direct
)
940 else !g#add_arc
((newi, exiti
), Direct
)
943 | _
-> raise Impossible
947 (* ------------------------- *)
952 ([{v_namei
= Some
(name
, _
); v_type
= typ
; v_storage
= sto
}, _
], _
)) ->
953 "decl:" ^
Ast_c.str_of_name name
954 | _
-> "decl_novar_or_multivar"
957 let newi = !g +> add_node (Decl
(decl
)) lbl s in
958 !g +> add_arc_opt (starti, newi);
961 (* ------------------------- *)
963 let newi = !g +> add_node (Asm
(stmt
, ((body
,ii)))) lbl "asm;" in
964 !g +> add_arc_opt (starti, newi);
968 let newi = !g +> add_node (MacroStmt
(stmt
, ((),ii))) lbl "macro;" in
969 !g +> add_arc_opt (starti, newi);
973 (* ------------------------- *)
974 | Ast_c.NestedFunc def
->
975 raise
(Error NestedFunc
)
983 and aux_statement_list
starti (xi
, newxi) statxs =
985 +> List.fold_left
(fun starti statement_seq
->
986 if !Flag_parsing_c.label_strategy_2
987 then incr
counter_for_labels;
990 if !Flag_parsing_c.label_strategy_2
991 then { newxi with labels
= xi
.labels
@ [ !counter_for_labels ] }
995 match statement_seq
with
996 | Ast_c.StmtElem statement
->
997 aux_statement
(starti, newxi'
) statement
999 | Ast_c.CppDirectiveStmt directive
->
1000 pr2_once
("ast_to_flow: filter a directive");
1003 | Ast_c.IfdefStmt ifdef
->
1004 pr2_once
("ast_to_flow: filter a directive");
1007 | Ast_c.IfdefStmt2
(ifdefs
, xxs
) ->
1009 let (head
, body
, tail
) = Common.head_middle_tail ifdefs
in
1011 let newi = !g +> add_node (IfdefHeader
(head
)) newxi'
.labels
"[ifdef]" in
1012 let taili = !g +> add_node (IfdefEndif
(tail
)) newxi'
.labels
"[endif]" in
1013 !g +> add_arc_opt (starti, newi);
1016 body
+> List.map
(fun elseif
->
1018 !g +> add_node (IfdefElse
(elseif
)) newxi'
.labels
"[elseif]" in
1019 !g#add_arc
((newi, elsei), Direct
);
1024 Common.zip
(newi::elsenodes) xxs
+> List.map
(fun (start_nodei
, xs
)->
1026 aux_statement_list
(Some start_nodei
) (newxi, newxi) xs
in
1027 !g +> add_arc_opt (finalthen, taili);
1035 (*****************************************************************************)
1036 (* Definition of function *)
1037 (*****************************************************************************)
1039 let (aux_definition
: nodei
-> definition
-> unit) = fun topi funcdef
->
1041 let lbl_start = [!counter_for_labels] in
1043 let ({f_name
= namefuncs
;
1048 f_old_c_style
= oldstyle
;
1050 let iifunheader, iicompound
=
1052 | ioparen
::icparen
::iobrace
::icbrace
::iifake
::isto
->
1053 ioparen
::icparen
::iifake
::isto
,
1055 | _
-> raise Impossible
1059 let topstatement = Ast_c.mk_st
(Ast_c.Compound compound
) iicompound
in
1061 let headi = !g +> add_node
1063 Ast_c.f_name
= namefuncs
;
1067 f_body
= [] (* empty body *);
1068 f_old_c_style
= oldstyle
;
1070 lbl_start ("function " ^
Ast_c.str_of_name namefuncs
) in
1071 let enteri = !g +> add_node Enter
lbl_0 "[enter]" in
1072 let exiti = !g +> add_node Exit
lbl_0 "[exit]" in
1073 let errorexiti = !g +> add_node ErrorExit
lbl_0 "[errorexit]" in
1075 !g#add_arc
((topi
, headi), Direct
);
1076 !g#add_arc
((headi, enteri), Direct
);
1078 (* ---------------------------------------------------------------- *)
1079 (* todocheck: assert ? such as we have "consommer" tous les labels *)
1083 labels_assoc
= compute_labels_and_create_them topstatement;
1085 errorexiti = Some
errorexiti;
1086 compound_caller
= FunctionDef
;
1090 let lasti = aux_statement
(Some
enteri, info) topstatement in
1091 !g +> add_arc_opt (lasti, exiti)
1093 (*****************************************************************************)
1095 (*****************************************************************************)
1097 (* Helpers for SpecialDeclMacro.
1099 * could also force the coccier to define
1100 * the toplevel macro statement as in @@ toplevel_declarator MACRO_PARAM;@@
1101 * and so I would not need this hack and instead I would to a cleaner
1102 * match in cocci_vs_c_3.ml of a A.MacroTop vs B.MacroTop
1104 * todo: update: now I do what I just described, so can remove this code ?
1106 let specialdeclmacro_to_stmt (s, args
, ii) =
1107 let (iis
, iiopar
, iicpar
, iiptvirg
) = tuple_of_list4
ii in
1108 let ident = Ast_c.RegularName
(s, [iis
]) in
1109 let identfinal = Ast_c.mk_e
(Ast_c.Ident
(ident)) Ast_c.noii
in
1110 let f = Ast_c.mk_e
(Ast_c.FunCall
(identfinal, args
)) [iiopar
;iicpar
] in
1111 let stmt = Ast_c.mk_st
(Ast_c.ExprStatement
(Some
f)) [iiptvirg
] in
1112 stmt, (f, [iiptvirg
])
1116 let ast_to_control_flow e
=
1118 (* globals (re)initialialisation *)
1119 g := (new ograph_mutable
);
1120 counter_for_labels := 1;
1121 counter_for_braces := 0;
1122 counter_for_switch := 0;
1124 let topi = !g +> add_node TopNode
lbl_0 "[top]" in
1127 | Ast_c.Definition
((defbis
,_
) as def
) ->
1128 let _funcs = defbis
.f_name
in
1129 let _c = defbis
.f_body
in
1130 (* if !Flag.show_misc then pr2 ("build info function " ^ funcs); *)
1131 aux_definition
topi def
;
1134 | Ast_c.Declaration _
1135 | Ast_c.CppTop
(Ast_c.Include _
)
1140 | Ast_c.Declaration decl
->
1141 (Control_flow_c.Decl decl
), "decl"
1142 | Ast_c.CppTop
(Ast_c.Include inc
) ->
1143 (Control_flow_c.Include inc
), "#include"
1144 | Ast_c.MacroTop
(s, args
, ii) ->
1145 let (st
, (e
, ii)) = specialdeclmacro_to_stmt (s, args
, ii) in
1146 (Control_flow_c.ExprStatement
(st
, (Some e
, ii))), "macrotoplevel"
1147 (*(Control_flow_c.MacroTop (s, args,ii), "macrotoplevel") *)
1148 | _
-> raise Impossible
1150 let ei = !g +> add_node elem
lbl_0 str
in
1151 let endi = !g +> add_node EndNode
lbl_0 "[end]" in
1153 !g#add_arc
((topi, ei),Direct
);
1154 !g#add_arc
((ei, endi),Direct
);
1157 | Ast_c.CppTop
(Ast_c.Define
((id
,ii), (defkind
, defval
))) ->
1158 let s = ("#define " ^ id
) in
1159 let headeri = !g+>add_node (DefineHeader
((id
, ii), defkind
)) lbl_0 s in
1160 !g#add_arc
((topi, headeri),Direct
);
1163 | Ast_c.DefineExpr e
->
1164 let ei = !g +> add_node (DefineExpr e
) lbl_0 "defexpr" in
1165 let endi = !g +> add_node EndNode
lbl_0 "[end]" in
1166 !g#add_arc
((headeri, ei) ,Direct
);
1167 !g#add_arc
((ei, endi) ,Direct
);
1169 | Ast_c.DefineType ft
->
1170 let ei = !g +> add_node (DefineType ft
) lbl_0 "deftyp" in
1171 let endi = !g +> add_node EndNode
lbl_0 "[end]" in
1172 !g#add_arc
((headeri, ei) ,Direct
);
1173 !g#add_arc
((ei, endi) ,Direct
);
1175 | Ast_c.DefineStmt st
->
1177 (* can have some return; inside the statement *)
1178 let exiti = !g +> add_node Exit
lbl_0 "[exit]" in
1179 let errorexiti = !g +> add_node ErrorExit
lbl_0 "[errorexit]" in
1180 let goto_labels = compute_labels_and_create_them st
in
1182 let info = { initial_info with
1183 labels_assoc
= goto_labels;
1185 errorexiti = Some
errorexiti;
1189 let lasti = aux_statement
(Some
headeri , info) st
in
1190 lasti +> do_option
(fun lasti ->
1191 (* todo? if don't have a lasti ? no EndNode ? CTL will work ? *)
1192 let endi = !g +> add_node EndNode
lbl_0 "[end]" in
1193 !g#add_arc
((lasti, endi), Direct
)
1197 | Ast_c.DefineDoWhileZero
((st
,_e
), ii) ->
1199 !g +> add_node (DefineDoWhileZeroHeader
((),ii)) lbl_0 "do0" in
1200 !g#add_arc
((headeri, headerdoi), Direct
);
1201 let info = initial_info in
1202 let lasti = aux_statement
(Some
headerdoi , info) st
in
1203 lasti +> do_option
(fun lasti ->
1204 let endi = !g +> add_node EndNode
lbl_0 "[end]" in
1205 !g#add_arc
((lasti, endi), Direct
)
1208 | Ast_c.DefineFunction def
->
1209 aux_definition
headeri def
;
1211 | Ast_c.DefineText
(s, s_ii
) ->
1212 raise
(Error
(Define
(pinfo_of_ii ii)))
1213 | Ast_c.DefineEmpty
->
1214 let endi = !g +> add_node EndNode
lbl_0 "[end]" in
1215 !g#add_arc
((headeri, endi),Direct
);
1216 | Ast_c.DefineInit _
->
1217 raise
(Error
(Define
(pinfo_of_ii ii)))
1218 | Ast_c.DefineTodo
->
1219 raise
(Error
(Define
(pinfo_of_ii ii)))
1222 | Ast_c.DefineText (s, ii) ->
1223 let endi = !g +> add_node EndNode lbl_0 "[end]" in
1224 !g#add_arc ((headeri, endi),Direct);
1225 | Ast_c.DefineInit _ ->
1226 let endi = !g +> add_node EndNode lbl_0 "[end]" in
1227 !g#add_arc ((headeri, endi),Direct);
1228 | Ast_c.DefineTodo ->
1229 let endi = !g +> add_node EndNode lbl_0 "[end]" in
1230 !g#add_arc ((headeri, endi),Direct);
1240 (*****************************************************************************)
1241 (* CFG loop annotation *)
1242 (*****************************************************************************)
1244 let annotate_loop_nodes g =
1245 let firsti = Control_flow_c.first_node
g in
1247 (* just for opti a little *)
1248 let already = Hashtbl.create
101 in
1250 g +> Ograph_extended.dfs_iter_with_path
firsti (fun xi path
->
1251 Hashtbl.add
already xi
true;
1252 let succ = g#successors xi
in
1253 let succ = succ#tolist
in
1254 succ +> List.iter
(fun (yi
,_edge
) ->
1255 if Hashtbl.mem
already yi
&& List.mem yi
(xi
::path
)
1257 let node = g#nodes#find yi
in
1258 let ((node2
, nodeinfo
), nodestr
) = node in
1259 let node'
= ((node2
, {nodeinfo
with is_loop
= true}), (nodestr ^
"*"))
1261 g#replace_node
(yi
, node'
);
1269 (*****************************************************************************)
1271 (*****************************************************************************)
1273 (* the second phase, deadcode detection. Old code was raising DeadCode if
1274 * lasti = None, but maybe not. In fact if have 2 return in the then
1275 * and else of an if ?
1277 * alt: but can assert that at least there exist
1278 * a node to exiti, just check #pred of exiti.
1280 * Why so many deadcode in Linux ? Ptet que le label est utilisé
1281 * mais dans le corps d'une macro et donc on le voit pas :(
1284 let deadcode_detection g =
1286 g#nodes#iter
(fun (k
, node) ->
1287 let pred = g#predecessors k
in
1289 (match unwrap
node with
1292 * | EndStatement _ -> pr2 "deadcode sur fake node, pas grave";
1297 | Exit
-> () (* if have 'loop: if(x) return; i++; goto loop' *)
1298 | SeqEnd _
-> () (* todo?: certaines '}' deviennent orphelins *)
1300 (match Control_flow_c.extract_fullstatement
node with
1302 let ii = Ast_c.get_ii_st_take_care st
in
1303 raise
(Error
(DeadCode
(Some
(pinfo_of_ii ii))))
1304 | _
-> pr2 "CFG: orphelin nodes, maybe something weird happened"
1309 (*------------------------------------------------------------------------*)
1310 (* special_cfg_braces: the check are really specific to the way we
1311 * have build our control_flow, with the { } in the graph so normally
1312 * all those checks here are useless.
1314 * ver1: to better error reporting, to report earlier the message, pass
1315 * the list of '{' (containing morover a brace_identifier) instead of
1319 let (check_control_flow
: cflow
-> unit) = fun g ->
1321 let nodes = g#
nodes in
1322 let starti = first_node
g in
1323 let visited = ref (new oassocb
[]) in
1325 let print_trace_error xs
= pr2 "PB with flow:"; Common.pr2_gen xs
; in
1327 let rec dfs (nodei
, (* Depth depth,*) startbraces
, trace
) =
1328 let trace2 = nodei
::trace
in
1329 if !visited#haskey nodei
1331 (* if loop back, just check that go back to a state where have same depth
1333 let (*(Depth depth2)*) startbraces2
= !visited#find nodei
in
1334 if (*(depth = depth2)*) startbraces
<> startbraces2
1337 pr2 (sprintf
"PB with flow: the node %d has not same braces count"
1339 print_trace_error trace2
1342 let children = g#successors nodei
in
1343 let _ = visited := !visited#add
(nodei
, (* Depth depth*) startbraces
) in
1345 (* old: good, but detect a missing } too late, only at the end
1347 (match fst (nodes#find nodei) with
1348 | StartBrace i -> Depth (depth + 1)
1349 | EndBrace i -> Depth (depth - 1)
1355 (match unwrap
(nodes#find nodei
), startbraces
with
1356 | SeqStart
(_,i
,_), xs
-> i
::xs
1357 | SeqEnd
(i
,_), j
::xs
->
1362 pr2 (sprintf
("PB with flow: not corresponding match between }%d and excpeted }%d at node %d") i j nodei
);
1363 print_trace_error trace2;
1366 | SeqEnd
(i
,_), [] ->
1367 pr2 (sprintf
"PB with flow: too much } at }%d " i
);
1368 print_trace_error trace2;
1375 if null
children#tolist
1377 if (* (depth = 0) *) startbraces
<> []
1378 then print_trace_error trace2
1380 children#tolist
+> List.iter
(fun (nodei
,_) ->
1381 dfs (nodei
, newdepth, trace2)
1385 dfs (starti, (* Depth 0*) [], [])
1387 (*****************************************************************************)
1389 (*****************************************************************************)
1391 let report_error error
=
1392 let error_from_info info =
1393 Common.error_message_short
info.file
("", info.charpos
)
1396 | DeadCode infoopt
->
1398 | None
-> pr2 "FLOW: deadcode detected, but cant trace back the place"
1399 | Some
info -> pr2 ("FLOW: deadcode detected: " ^
error_from_info info)
1401 | CaseNoSwitch
info ->
1402 pr2 ("FLOW: case without corresponding switch: " ^
error_from_info info)
1403 | OnlyBreakInSwitch
info ->
1404 pr2 ("FLOW: only break are allowed in switch: " ^
error_from_info info)
1405 | WeirdSwitch
info ->
1406 pr2 ("FLOW: weird switch: " ^
error_from_info info)
1407 | NoEnclosingLoop
(info) ->
1408 pr2 ("FLOW: can't find enclosing loop: " ^
error_from_info info)
1409 | GotoCantFindLabel
(s, info) ->
1410 pr2 ("FLOW: cant jump to " ^
s ^
": because we can't find this label")
1412 pr2 ("FLOW: can't find exit or error exit: " ^
error_from_info info)
1413 | DuplicatedLabel
s ->
1414 pr2 ("FLOW: duplicate label " ^
s)
1416 pr2 ("FLOW: not handling yet nested function")
1418 pr2 ("FLOW: not handling computed goto yet")
1420 pr2 ("Unsupported form of #define: " ^
error_from_info info)