diff --git a/Makefile b/Makefile index b50ecd3..44dd3b0 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -.PHONY: clean examples check dca +.PHONY: lexifi clean examples check dca dca: dune build dead_code_analyzer.install @@ -13,3 +13,6 @@ clean: dune clean make -C examples clean make -C check clean + +lexifi: + dune build src/deadLexiFi.exe diff --git a/src/deadCode.ml b/src/deadCode.ml index faaf0fa..b534ede 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -696,7 +696,7 @@ let run_analysis state = state.State.config.paths_to_analyze state -let () = +let run () = try let config = Config.parse_cli () in let state = State.init config in diff --git a/src/deadCode.mli b/src/deadCode.mli index 7bfe34d..c12c021 100644 --- a/src/deadCode.mli +++ b/src/deadCode.mli @@ -200,3 +200,5 @@ See option {b -E} for the syntax of {b --help} Display this list of options *) + +val run : unit -> unit diff --git a/src/deadCodeAnalyzer.ml b/src/deadCodeAnalyzer.ml new file mode 100644 index 0000000..61cd8f1 --- /dev/null +++ b/src/deadCodeAnalyzer.ml @@ -0,0 +1 @@ +let () = DeadLib.DeadCode.run () diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index 2fd3187..6dd014d 100644 --- a/src/deadLexiFi.ml +++ b/src/deadLexiFi.ml @@ -19,7 +19,9 @@ open Parsetree open Types open Typedtree -open DeadCommon +open DeadLib.DeadCommon + +module State = DeadLib.State (******** ATTRIBUTES ********) @@ -31,144 +33,133 @@ let used = ref [] let field_link = Hashtbl.create 256 let dyn_used = Hashtbl.create 256 - - -let () = - - DeadLexiFi.sig_value := - (fun value -> - let add strct = match strct.pstr_desc with - | Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _}, _) -> - hashtbl_add_unique_to_list str s value.val_loc.loc_start - | _ -> () - in - let add = function - | {attr_name = {txt = "mlfi.value_approx"; _}; attr_payload = PStr structure; _} -> - List.iter add structure - | _ -> () - in - List.iter add value.val_attributes - ); - - - DeadLexiFi.type_ext := - (fun ct -> - (* TO CHECK *) - List.iter - (fun {attr_name = {txt; _}; _} -> - used := (txt, ct.ctyp_loc.loc_start) :: !used; +let sig_value (value : Types.value_description) = + let add strct = match strct.pstr_desc with + | Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _}, _) -> + hashtbl_add_unique_to_list str s value.val_loc.loc_start + | _ -> () + in + let add = function + | {attr_name = {txt = "mlfi.value_approx"; _}; attr_payload = PStr structure; _} -> + List.iter add structure + | _ -> () + in + List.iter add value.val_attributes + +let type_ext ct = + (* TO CHECK *) + List.iter + (fun {attr_name = {txt; _}; _} -> + used := (txt, ct.ctyp_loc.loc_start) :: !used; + ) + ct.ctyp_attributes + +let type_decl td = + List.iter + (fun {attr_name = {txt; _}; _} -> + used := (txt, td.typ_loc.loc_start) :: !used; + ) + td.typ_type.type_attributes + +let tstr_type typ ctype = + let state = State.get_current () in + let modname = State.File_infos.get_modname state.file_infos in + let path = + let partial_path_rev = + typ.typ_name.Asttypes.txt :: !mods + in + modname :: List.rev partial_path_rev + |> String.concat "." + in + let is_user_defined s = + let l = [_variant; "bool"; "float"; "int"; "string"; "unit"] in + let mod_name = + let rec loop s pos len = + if len = String.length s then s + else if s.[pos] = '.' then String.sub s (pos - len) len + else loop s (pos + 1) (len + 1) + in loop s 0 0 + in + not (String.contains s ' ') + && (s <> String.capitalize_ascii s && not (List.mem s l) + || String.contains s '.' && mod_name <> "Pervasives") + in + if is_user_defined ctype then + hashtbl_add_to_list field_link path ctype + +let ttype_of e = + let state = State.get_current () in + let modname = State.File_infos.get_modname state.file_infos in + let name = + List.rev (modname :: !mods) + |> String.concat "." + in + let call_site = + if e.exp_loc.Location.loc_ghost then !last_loc + else e.exp_loc.Location.loc_start + in + dyn_rec := (name, e.exp_type, call_site) :: !dyn_rec + +let prepare_report decs = + let state = State.get_current () in + let sections = state.config.sections in + List.iter + (fun (strin, pos) -> + hashtbl_find_list str strin + |> List.iter + (fun loc -> + if exported sections.exported_values loc then + LocHash.add_set references loc pos ) - ct.ctyp_attributes - ); - - DeadLexiFi.type_decl := - (fun td -> - List.iter - (fun {attr_name = {txt; _}; _} -> - used := (txt, td.typ_loc.loc_start) :: !used; - ) - td.typ_type.type_attributes - ); - - - DeadLexiFi.tstr_type := - (fun typ ctype -> - let state = State.get_current () in - let modname = State.File_infos.get_modname state.file_infos in - let path = - let partial_path_rev = - typ.typ_name.Asttypes.txt :: !mods + ) + !used; + let rec process (p, typ, call_site) = + match get_deep_desc typ with + | Tarrow (_, t, _, _) -> process (p, t, call_site) + | Ttuple ts -> List.iter (fun t -> process (p, t, call_site)) ts + | Tconstr (path, ts, _) -> + let name = Path.name path in + let name = + if String.contains name '.' then name + else p ^ "." ^ name in - modname :: List.rev partial_path_rev - |> String.concat "." - in - let is_user_defined s = - let l = [_variant; "bool"; "float"; "int"; "string"; "unit"] in - let mod_name = - let rec loop s pos len = - if len = String.length s then s - else if s.[pos] = '.' then String.sub s (pos - len) len - else loop s (pos + 1) (len + 1) - in loop s 0 0 + let met = ref [] in + let rec proc name = + if not (List.mem name !met) then begin + met := name :: !met; + name :: List.fold_left (fun acc name -> acc @ (proc name)) [] (hashtbl_find_list field_link name) + end + else [] in - not (String.contains s ' ') - && (s <> String.capitalize_ascii s && not (List.mem s l) - || String.contains s '.' && mod_name <> "Pervasives") - in - if is_user_defined ctype then - hashtbl_add_to_list field_link path ctype - ); - - - DeadLexiFi.ttype_of := - (fun e -> - let state = State.get_current () in - let modname = State.File_infos.get_modname state.file_infos in - let name = - List.rev (modname :: !mods) - |> String.concat "." - in - let call_site = - if e.exp_loc.Location.loc_ghost then !last_loc - else e.exp_loc.Location.loc_start + List.iter + (fun typ -> + hashtbl_add_to_list dyn_used typ call_site + ) + (proc name); + List.iter (fun t -> process (p, t, call_site)) ts + | _ -> () + in + List.iter process !dyn_rec; + Hashtbl.iter + (fun loc (_, path) -> + let rec get_type s pos = + if pos = 0 then s + else if s.[pos] = '.' then String.sub s 0 pos + else get_type s (pos - 1) in - dyn_rec := (name, e.exp_type, call_site) :: !dyn_rec - ); - - - DeadLexiFi.prepare_report := - (fun decs -> - let state = State.get_current () in - let sections = state.config.sections in List.iter - (fun (strin, pos) -> - hashtbl_find_list str strin - |> List.iter - (fun loc -> - if exported sections.exported_values loc then - LocHash.add_set references loc pos - ) + ( if exported ~is_type:true sections.types loc then LocHash.add_set references loc + else ignore ) - !used; - let rec process (p, typ, call_site) = - match get_deep_desc typ with - | Tarrow (_, t, _, _) -> process (p, t, call_site) - | Ttuple ts -> List.iter (fun t -> process (p, t, call_site)) ts - | Tconstr (path, ts, _) -> - let name = Path.name path in - let name = - if String.contains name '.' then name - else p ^ "." ^ name - in - let met = ref [] in - let rec proc name = - if not (List.mem name !met) then begin - met := name :: !met; - name :: List.fold_left (fun acc name -> acc @ (proc name)) [] (hashtbl_find_list field_link name) - end - else [] - in - List.iter - (fun typ -> - hashtbl_add_to_list dyn_used typ call_site - ) - (proc name); - List.iter (fun t -> process (p, t, call_site)) ts - | _ -> () - in - List.iter process !dyn_rec; - Hashtbl.iter - (fun loc (_, path) -> - let rec get_type s pos = - if pos = 0 then s - else if s.[pos] = '.' then String.sub s 0 pos - else get_type s (pos - 1) - in - List.iter - ( if exported ~is_type:true sections.types loc then LocHash.add_set references loc - else ignore - ) - (hashtbl_find_list dyn_used (get_type path (String.length path - 1))) - ) - decs - ); + (hashtbl_find_list dyn_used (get_type path (String.length path - 1))) + ) + decs + +let () = + DeadLexiFi.sig_value := sig_value; + DeadLexiFi.type_ext := type_ext; + DeadLexiFi.type_decl := type_decl; + DeadLexiFi.tstr_type := tstr_type; + DeadLexiFi.ttype_of := ttype_of; + DeadLexiFi.prepare_report := prepare_report; + DeadLib.DeadCode.run () diff --git a/src/deadLexiFi.mli b/src/deadLexiFi.mli new file mode 100644 index 0000000..63cb2c6 --- /dev/null +++ b/src/deadLexiFi.mli @@ -0,0 +1 @@ +(** Loading this module sets the extensions internally used at LexiFi. *) diff --git a/src/dune b/src/dune index 20d1c70..7ffe239 100644 --- a/src/dune +++ b/src/dune @@ -1,6 +1,18 @@ +(library + (public_name dead_code_analyzer.lib) + (name deadLib) + (modules (:standard \ deadCodeAnalyzer deadLexiFi)) + (libraries compiler-libs.common)) + (executable (public_name dead_code_analyzer) - (name deadCode) - (libraries compiler-libs.common)) + (name deadCodeAnalyzer) + (modules DeadCodeAnalyzer) + (libraries dead_code_analyzer.lib)) + +(executable + (name deadLexiFi) + (modules DeadLexiFi) + (libraries dead_code_analyzer.lib)) (include_subdirs unqualified)