X-Git-Url: http://git.hcoop.net/bpt/coccinelle.git/blobdiff_plain/413ffc021412f98847aeb825928e9e0e79dd2648..f537ebc4bbd27866c9ac3e1198b6756ebab7f2ba:/cocci.ml diff --git a/cocci.ml b/cocci.ml index 8073594..5a86ffa 100644 --- a/cocci.ml +++ b/cocci.ml @@ -44,39 +44,65 @@ module Ast_to_flow = Control_flow_c_build (* --------------------------------------------------------------------- *) (* C related *) (* --------------------------------------------------------------------- *) -let cprogram_of_file file = - let (program2, _stat) = Parse_c.parse_c_and_cpp file in +let cprogram_of_file saved_typedefs saved_macros file = + let (program2, _stat) = + Parse_c.parse_c_and_cpp_keep_typedefs + (Some saved_typedefs) (Some saved_macros) file in program2 let cprogram_of_file_cached file = - let (program2, _stat) = Parse_c.parse_cache file in + let ((program2,typedefs,macros), _stat) = Parse_c.parse_cache file in if !Flag_cocci.ifdef_to_if then - program2 +> Parse_c.with_program2 (fun asts -> - Cpp_ast_c.cpp_ifdef_statementize asts - ) - else program2 + let p2 = + program2 +> Parse_c.with_program2 (fun asts -> + Cpp_ast_c.cpp_ifdef_statementize asts + ) in + (p2,typedefs,macros) + else (program2,typedefs,macros) let cfile_of_program program2_with_ppmethod outf = Unparse_c.pp_program program2_with_ppmethod outf (* for memoization, contains only one entry, the one for the SP *) let _hparse = Hashtbl.create 101 +let _h_ocaml_init = Hashtbl.create 101 let _hctl = Hashtbl.create 101 (* --------------------------------------------------------------------- *) (* Cocci related *) (* --------------------------------------------------------------------- *) -let sp_of_file2 file iso = - Common.memoized _hparse (file, iso) (fun () -> - let (_,xs,_,_,_,_,_,_) as res = Parse_cocci.process file iso false in - (match Prepare_ocamlcocci.prepare file xs with - None -> () - | Some ocaml_script_file -> - (* compile file *) - Prepare_ocamlcocci.load_file ocaml_script_file; - Prepare_ocamlcocci.clean_file ocaml_script_file); - res) +(* for a given pair (file,iso), only keep an instance for the most recent +virtual rules and virtual_env *) + +let sp_of_file2 file iso = + let redo _ = + let new_code = + let (_,xs,_,_,_,_,_) as res = Parse_cocci.process file iso false in + (* if there is already a compiled ML code, do nothing and use that *) + try let _ = Hashtbl.find _h_ocaml_init (file,iso) in res + with Not_found -> + begin + Hashtbl.add _h_ocaml_init (file,iso) (); + match Prepare_ocamlcocci.prepare file xs with + None -> res + | Some ocaml_script_file -> + (* compile file *) + Prepare_ocamlcocci.load_file ocaml_script_file; + (if not !Common.save_tmp_files + then Prepare_ocamlcocci.clean_file ocaml_script_file); + res + end in + Hashtbl.add _hparse (file,iso) + (!Flag.defined_virtual_rules,!Flag.defined_virtual_env,new_code); + new_code in + try + let (rules,env,code) = Hashtbl.find _hparse (file,iso) in + if rules = !Flag.defined_virtual_rules && env = !Flag.defined_virtual_env + then code + else (Hashtbl.remove _hparse (file,iso); redo()) + with Not_found -> redo() + let sp_of_file file iso = Common.profile_code "parse cocci" (fun () -> sp_of_file2 file iso) @@ -268,24 +294,26 @@ let show_or_not_diff2 cfile outfile = let diff_line = match List.rev(Str.split (Str.regexp " ") line) with new_file::old_file::cmdrev -> + let old_base_file = drop_prefix old_file in if !Flag.sgrep_mode2 then String.concat " " - (List.rev ("/tmp/nothing" :: old_file :: cmdrev)) + (List.rev + (("/tmp/nothing"^old_base_file) + :: old_file :: cmdrev)) else - let old_base_file = drop_prefix old_file in String.concat " " (List.rev (("b"^old_base_file)::("a"^old_base_file)::cmdrev)) | _ -> failwith "bad command" in let (minus_line,plus_line) = - if !Flag.sgrep_mode2 - then (minus_file,"+++ /tmp/nothing") - else - match (Str.split (Str.regexp "[ \t]") minus_file, - Str.split (Str.regexp "[ \t]") plus_file) with - ("---"::old_file::old_rest,"+++"::new_file::new_rest) -> - let old_base_file = drop_prefix old_file in + match (Str.split (Str.regexp "[ \t]") minus_file, + Str.split (Str.regexp "[ \t]") plus_file) with + ("---"::old_file::old_rest,"+++"::new_file::new_rest) -> + let old_base_file = drop_prefix old_file in + if !Flag.sgrep_mode2 + then (minus_file,"+++ /tmp/nothing"^old_base_file) + else (String.concat " " ("---"::("a"^old_base_file)::old_rest), String.concat " " @@ -516,7 +544,7 @@ let sp_contain_typed_metavar_z toplevel_list_list = let combiner = Visitor_ast.combiner bind option_default mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode - donothing donothing donothing donothing + donothing donothing donothing donothing donothing donothing expression donothing donothing donothing donothing donothing donothing donothing donothing donothing donothing in @@ -548,32 +576,60 @@ let sp_contain_typed_metavar rules = * For the moment we base in part our heuristic on the name of the file, e.g. * serio.c is related we think to #include *) -let rec search_include_path searchlist relpath = - match searchlist with - [] -> Some relpath - | hd::tail -> - let file = Filename.concat hd relpath in - if Sys.file_exists file then - Some file - else - search_include_path tail relpath +let include_table = Hashtbl.create(100) let interpret_include_path relpath = + let maxdepth = List.length relpath in + let unique_file_exists dir f = + let cmd = + Printf.sprintf "find %s -maxdepth %d -mindepth %d -path \"*/%s\"" + dir maxdepth maxdepth f in + match Common.cmd_to_list cmd with + [x] -> Some x + | _ -> None in + let native_file_exists dir f = + let f = Filename.concat dir f in + if Sys.file_exists f + then Some f + else None in + let rec search_include_path exists searchlist relpath = + match searchlist with + [] -> None + | hd::tail -> + (match exists hd relpath with + Some x -> Some x + | None -> search_include_path exists tail relpath) in + let rec search_path exists searchlist = function + [] -> + let res = Common.concat "/" relpath in + Hashtbl.add include_table (searchlist,relpath) res; + Some res + | (hd::tail) as relpath1 -> + let relpath1 = Common.concat "/" relpath1 in + (match search_include_path exists searchlist relpath1 with + None -> search_path unique_file_exists searchlist tail + | Some f -> + Hashtbl.add include_table (searchlist,relpath) f; + Some f) in let searchlist = match !Flag_cocci.include_path with - [] -> ["include"] - | x -> List.rev x - in - search_include_path searchlist relpath + [] -> ["include"] + | x -> List.rev x in + try Some(Hashtbl.find include_table (searchlist,relpath)) + with Not_found -> + search_path native_file_exists searchlist relpath let (includes_to_parse: - (Common.filename * Parse_c.program2) list -> + (Common.filename * Parse_c.extended_program2) list -> Flag_cocci.include_options -> 'a) = fun xs choose_includes -> match choose_includes with Flag_cocci.I_UNSPECIFIED -> failwith "not possible" | Flag_cocci.I_NO_INCLUDES -> [] | x -> - let all_includes = x =*= Flag_cocci.I_ALL_INCLUDES in + let all_includes = + List.mem x + [Flag_cocci.I_ALL_INCLUDES; Flag_cocci.I_REALLY_ALL_INCLUDES] in + let xs = List.map (function (file,(cs,_,_)) -> (file,cs)) xs in xs +> List.map (fun (file, cs) -> let dir = Common.dirname file in @@ -585,7 +641,7 @@ let (includes_to_parse: (match x with | Ast_c.Local xs -> let relpath = Common.join "/" xs in - let f = Filename.concat dir (relpath) in + let f = Filename.concat dir relpath in if (Sys.file_exists f) then Some f else @@ -595,24 +651,23 @@ let (includes_to_parse: let attempt2 = Filename.concat dir (Common.last xs) in if not (Sys.file_exists attempt2) && all_includes then - interpret_include_path relpath + interpret_include_path xs else Some attempt2 else - if all_includes then interpret_include_path relpath + if all_includes then interpret_include_path xs else None | Ast_c.NonLocal xs -> - let relpath = Common.join "/" xs in if all_includes || Common.fileprefix (Common.last xs) =$= Common.fileprefix file then - interpret_include_path relpath + interpret_include_path xs else None | Ast_c.Weird _ -> None ) | _ -> None)) +> List.concat - +> Common.uniq + +> (fun x -> (List.rev (Common.uniq (List.rev x)))) (*uniq keeps last*) let rec interpret_dependencies local global = function Ast_cocci.Dep s -> List.mem s local @@ -761,6 +816,9 @@ type toplevel_c_info = { was_modified: bool ref; + all_typedefs: (string, Lexer_parser.identkind) Common.scoped_h_env; + all_macros: (string, Cpp_token_c.define_def) Hashtbl.t; + (* id: int *) } @@ -948,7 +1006,7 @@ let prepare_cocci ctls free_var_lists negated_pos_lists (* --------------------------------------------------------------------- *) -let build_info_program cprogram env = +let build_info_program (cprogram,typedefs,macros) env = let (cs, parseinfos) = Common.unzip cprogram in @@ -994,6 +1052,9 @@ let build_info_program cprogram env = env_typing_after = envb; was_modified = ref false; + + all_typedefs = typedefs; + all_macros = macros; } ) @@ -1010,7 +1071,7 @@ let rebuild_info_program cs file isexp = file; (* Common.command2 ("cat " ^ file); *) - let cprogram = cprogram_of_file file in + let cprogram = cprogram_of_file c.all_typedefs c.all_macros file in let xs = build_info_program cprogram c.env_typing_before in (* TODO: assert env has not changed, @@ -1034,63 +1095,75 @@ let rebuild_info_c_and_headers ccs isexp = rebuild_info_program c_or_h.asts c_or_h.full_fname isexp } ) - +let rec prepare_h seen env hpath choose_includes : file_info list = + if not (Common.lfile_exists hpath) + then + begin + pr2_once ("TYPE: header " ^ hpath ^ " not found"); + [] + end + else + begin + let h_cs = cprogram_of_file_cached hpath in + let local_includes = + if choose_includes =*= Flag_cocci.I_REALLY_ALL_INCLUDES + then + List.filter + (function x -> not (List.mem x !seen)) + (includes_to_parse [(hpath,h_cs)] choose_includes) + else [] in + seen := local_includes @ !seen; + let others = + List.concat + (List.map (function x -> prepare_h seen env x choose_includes) + local_includes) in + let info_h_cs = build_info_program h_cs !env in + env := + if null info_h_cs + then !env + else last_env_toplevel_c_info info_h_cs; + others@ + [{ + fname = Common.basename hpath; + full_fname = hpath; + asts = info_h_cs; + was_modified_once = ref false; + fpath = hpath; + fkind = Header; + }] + end let prepare_c files choose_includes : file_info list = let cprograms = List.map cprogram_of_file_cached files in let includes = includes_to_parse (zip files cprograms) choose_includes in + let seen = ref includes in (* todo?: may not be good to first have all the headers and then all the c *) - let all = - (includes +> List.map (fun hpath -> Right hpath)) - ++ - ((zip files cprograms) +> - List.map (fun (file, asts) -> Left (file, asts))) - in - let env = ref !TAC.initial_env in - let ccs = all +> Common.map_filter (fun x -> - match x with - | Right hpath -> - if not (Common.lfile_exists hpath) - then begin - pr2 ("TYPE: header " ^ hpath ^ " not found"); - None - end - else - let h_cs = cprogram_of_file_cached hpath in - let info_h_cs = build_info_program h_cs !env in - env := - if null info_h_cs - then !env - else last_env_toplevel_c_info info_h_cs - ; - Some { - fname = Common.basename hpath; - full_fname = hpath; - asts = info_h_cs; - was_modified_once = ref false; - fpath = hpath; - fkind = Header; - } - | Left (file, cprogram) -> - (* todo?: don't update env ? *) + let includes = + includes +> + List.map (function hpath -> prepare_h seen env hpath choose_includes) +> + List.concat in + + let cfiles = + (zip files cprograms) +> + List.map + (function (file, cprogram) -> + (* todo?: don't update env ? *) let cs = build_info_program cprogram !env in (* we do that only for the c, not for the h *) ignore(update_include_rel_pos (cs +> List.map (fun x -> x.ast_c))); - Some { - fname = Common.basename file; - full_fname = file; - asts = cs; - was_modified_once = ref false; - fpath = file; - fkind = Source; - } - ) - in - ccs + { + fname = Common.basename file; + full_fname = file; + asts = cs; + was_modified_once = ref false; + fpath = file; + fkind = Source + }) in + includes @ cfiles (*****************************************************************************) (* Processing the ctls and toplevel C elements *) @@ -1202,6 +1275,7 @@ let ocaml_application mv ve script_vars r = else None with e -> (pr2 ("Failure in " ^ r.scr_rule_info.rulename); raise e) +(* returns Left in case of dependency failure, Right otherwise *) let apply_script_rule r cache newes e rules_that_have_matched rules_that_have_ever_matched script_application = Common.profile_code r.language (fun () -> @@ -1231,21 +1305,23 @@ let apply_script_rule r cache newes e rules_that_have_matched List.exists (function (_,(r,m),_) -> r =*= re && m =$= rm) mv) e in (try - let script_vals = List.assoc relevant_bindings cache in - print_dependencies - "dependencies for script satisfied, but cached:" - rules_that_have_matched - !rules_that_have_ever_matched - r.scr_rule_info.dependencies; - show_or_not_binding "in" e; + match List.assoc relevant_bindings cache with + None -> (cache,newes) + | Some script_vals -> + print_dependencies + "dependencies for script satisfied, but cached:" + rules_that_have_matched + !rules_that_have_ever_matched + r.scr_rule_info.dependencies; + show_or_not_binding "in" e; (* env might be bigger than what was cached against, so have to merge with newes anyway *) - let new_e = (List.combine script_vars script_vals) @ e in - let new_e = - new_e +> - List.filter - (fun (s,v) -> List.mem s r.scr_rule_info.used_after) in - (cache,merge_env [(new_e, rules_that_have_matched)] newes) + let new_e = (List.combine script_vars script_vals) @ e in + let new_e = + new_e +> + List.filter + (fun (s,v) -> List.mem s r.scr_rule_info.used_after) in + (cache,merge_env [(new_e, rules_that_have_matched)] newes) with Not_found -> begin print_dependencies "dependencies for script satisfied:" @@ -1256,7 +1332,7 @@ let apply_script_rule r cache newes e rules_that_have_matched match script_application mv ve script_vars r with None -> (* failure means we should drop e, no new bindings *) - (((relevant_bindings,[]) :: cache), newes) + (((relevant_bindings,None) :: cache), newes) | Some script_vals -> let script_vals = List.map (function x -> Ast_c.MetaIdVal(x,[])) @@ -1268,7 +1344,7 @@ let apply_script_rule r cache newes e rules_that_have_matched List.filter (fun (s,v) -> List.mem s r.scr_rule_info.used_after) in r.scr_rule_info.was_matched := true; - (((relevant_bindings,script_vals) :: cache), + (((relevant_bindings,Some script_vals) :: cache), merge_env [(new_e, r.scr_rule_info.rulename :: rules_that_have_matched)] @@ -1553,7 +1629,8 @@ and process_a_ctl_a_env_a_toplevel2 r e c f = r.rule_info.was_matched := true; - if not (null trans_info) + if not (null trans_info) && + not (!Flag.sgrep_mode2 && not !Flag_cocci.show_diff) then begin c.was_modified := true; try @@ -1630,7 +1707,7 @@ let rec bigloop2 rs (ccs: file_info list) = then Common.push2 r.scr_rule_info.rulename rules_that_have_ever_matched); - es := (if newes = [] then init_es else newes); + es := newes (*(if newes = [] then init_es else newes)*); | CocciRuleCocciInfo r -> apply_cocci_rule r rules_that_have_ever_matched es ccs); @@ -1681,8 +1758,8 @@ let initial_final_bigloop2 ty rebuild r = let _ = apply_script_rule r [] [] [] [] (ref []) ocaml_application in () | _ -> - Printf.printf "Unknown language for initial/final script: %s\n" - r.language + failwith ("Unknown language for initial/final script: "^ + r.language) let initial_final_bigloop a b c = Common.profile_code "initial_final_bigloop" @@ -1707,7 +1784,7 @@ let pre_engine2 (coccifile, isofile) = (* useful opti when use -dir *) let (metavars,astcocci, free_var_lists,negated_pos_lists,used_after_lists, - positions_lists,toks,_) = + positions_lists,(toks,_,_)) = sp_of_file coccifile isofile in let ctls = ctls_of_ast astcocci used_after_lists positions_lists in @@ -1733,32 +1810,42 @@ let pre_engine2 (coccifile, isofile) = | _ -> languages) [] cocci_infos in + let runrule r = + let rlang = r.language in + let rname = r.scr_rule_info.rulename in + try + let _ = List.assoc (rlang,rname) !Iteration.initialization_stack in + () + with Not_found -> + begin + Iteration.initialization_stack := + ((rlang,rname),!Flag.defined_virtual_rules) :: + !Iteration.initialization_stack; + initial_final_bigloop Initial + (fun (x,_,_,y) -> fun deps -> + Ast_cocci.InitialScriptRule(rname,x,deps,y)) + r + end in + let initialized_languages = List.fold_left (function languages -> - function - InitialScriptRuleCocciInfo(r) -> - (if List.mem r.language languages - then - failwith - ("double initializer found for "^r.language)); - if interpret_dependencies [] [] r.scr_rule_info.dependencies - then - begin - initial_final_bigloop Initial - (fun (x,_,_,y) -> fun deps -> - Ast_cocci.InitialScriptRule(r.scr_rule_info.rulename,x,deps,y)) - r; - r.language::languages - end - else languages - | _ -> languages) + function + InitialScriptRuleCocciInfo(r) -> + let rlang = r.language in + (if List.mem rlang languages + then failwith ("double initializer found for "^rlang)); + if interpret_dependencies [] [] r.scr_rule_info.dependencies + then begin runrule r; rlang::languages end + else languages + | _ -> languages) [] cocci_infos in let uninitialized_languages = List.filter (fun used -> not (List.mem used initialized_languages)) used_languages in + List.iter (fun lgg -> let rule_info = @@ -1767,10 +1854,7 @@ let pre_engine2 (coccifile, isofile) = used_after = []; ruleid = (-1); was_matched = ref false;} in - initial_final_bigloop Initial - (fun (x,_,_,y) -> fun deps -> - Ast_cocci.InitialScriptRule("",x,deps,y)) - (make_init lgg "" rule_info)) + runrule (make_init lgg "" rule_info)) uninitialized_languages; (cocci_infos,toks) @@ -1843,21 +1927,26 @@ let full_engine a b = (fun () -> let res = full_engine2 a b in (*Gc.print_stat stderr; *)res) let post_engine2 (cocci_infos,_) = - let _ = - List.fold_left - (function languages -> - function - FinalScriptRuleCocciInfo(r) -> - (if List.mem r.language languages - then failwith ("double finalizer found for "^r.language)); - initial_final_bigloop Final - (fun (x,_,_,y) -> fun deps -> - Ast_cocci.FinalScriptRule(r.scr_rule_info.rulename,x,deps,y)) - r; - r.language::languages - | _ -> languages) - [] cocci_infos in - () + List.iter + (function ((language,_),virt_rules) -> + Flag.defined_virtual_rules := virt_rules; + let _ = + List.fold_left + (function languages -> + function + FinalScriptRuleCocciInfo(r) -> + (if r.language = language && List.mem r.language languages + then failwith ("double finalizer found for "^r.language)); + initial_final_bigloop Final + (fun (x,_,_,y) -> fun deps -> + Ast_cocci.FinalScriptRule(r.scr_rule_info.rulename, + x,deps,y)) + r; + r.language::languages + | _ -> languages) + [] cocci_infos in + ()) + !Iteration.initialization_stack let post_engine a = Common.profile_code "post_engine" (fun () -> post_engine2 a)