diff --git a/docs/USAGE.md b/docs/USAGE.md index 3d33a86..2969ca1 100644 --- a/docs/USAGE.md +++ b/docs/USAGE.md @@ -220,8 +220,8 @@ To ignore that module, both for declarations and uses, one can use the ### `--references ` Using the previous command line, some reported elements (e.g. located in -`src/lib/lib.mli`) could be used by the `Debug` module. In this situation. -In this case, completely excluding `src/debug` from the analysis leads to false +`src/lib/lib.mli`) could be used by the `Debug` module. In this situation, +completely excluding `src/debug` from the analysis leads to false positives (FP): invalid reports. To fix the situation, one can use the `--references ` option. This option diff --git a/src/deadArg.ml b/src/deadArg.ml index 7150042..5221644 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -12,140 +12,159 @@ open Typedtree open DeadCommon - -let later = ref [] -let last = ref [] +let at_eof = ref [] +let at_eocb = ref [] let met = Hashtbl.create 512 - -let eom () = - List.iter (fun f -> f ()) !later; - later := []; +let eof () = + List.iter (fun f -> f ()) !at_eof; + at_eof := []; Hashtbl.reset met +let eocb () = + List.iter (fun f -> f ()) !at_eocb -let add lab expr builddir loc last_loc nb_occur = - let has_val = match expr.exp_desc with +let increment_count label count_tbl = + let count = Hashtbl.find_opt count_tbl label |> Option.value ~default:0 in + let count = count + 1 in + Hashtbl.replace count_tbl label count; + count + +let register_use label expr builddir loc last_loc count_tbl = + let has_val = + match expr.exp_desc with | Texp_construct (_, {cstr_name = "None"; _}, _) -> false | _ -> true in - let occur = - let occur = - if not (Hashtbl.mem nb_occur lab) then Hashtbl.add nb_occur lab 1 - else Hashtbl.find nb_occur lab + 1 |> Hashtbl.replace nb_occur lab; - Hashtbl.find nb_occur lab - in ref occur - in + let count = increment_count label count_tbl in let call_site = if expr.exp_loc.Location.loc_ghost then last_loc else expr.exp_loc.Location.loc_start in - if check_underscore lab then - let loc = VdNode.find loc lab occur in - if not (Hashtbl.mem met (last_loc, loc, lab)) then begin - Hashtbl.add met (last_loc, loc, lab) (); + if check_underscore label then + let loc = VdNode.find loc label count in + if not (Hashtbl.mem met (last_loc, loc, label)) then ( + Hashtbl.add met (last_loc, loc, label) (); let opt_arg_use = { builddir; decl_loc = loc; - label = lab; + label; has_val; use_loc = call_site; - } + } in opt_args := opt_arg_use :: !opt_args - end - - -let rec process loc args = - - List.iter (* treat each arg's expression before all (even if ghost) *) - (function - | (_, Some e) -> check e - | _ -> ()) + ) + +let deferrable_register_use label expr builddir loc last_loc count_tbl = + let register_use () = register_use label expr builddir loc last_loc count_tbl in + if VdNode.is_end loc then + let fn = loc.Lexing.pos_fname in + if fn.[String.length fn - 1] = 'i' then + (* TODO: + * What does it mean to have a loc in a signature ? + * When does it happen ? *) + at_eocb := register_use :: !at_eocb + else if !depth > 0 then at_eof := register_use :: !at_eof + else register_use () + else register_use () + +let rec register_uses builddir loc args = + List.iter + (fun (_, e) -> Option.iter (register_higher_order_uses builddir) e) args; - - if is_ghost loc then () (* Ghostbuster *) - else begin (* else: `begin ... end' for aesthetics *) - let nb_occur = Hashtbl.create 256 in - let last_loc = !last_loc in - let builddir = - let state = State.get_current () in - State.File_infos.get_builddir state.file_infos - in - (* last_loc and builddir fixed to avoid side effects if added to later/last *) - let add lab expr = add lab expr builddir loc last_loc nb_occur in - let add = function - | (Asttypes.Optional lab, Some expr) -> - if VdNode.is_end loc - && (let fn = loc.Lexing.pos_fname in fn.[String.length fn - 1] = 'i') then - last := (fun () -> add lab expr) :: !last - else if VdNode.is_end loc && !depth > 0 then - later := (fun () -> add lab expr) :: !later - else - add lab expr + if is_ghost loc then () (* Ghostbuster *) + else + let count_tbl = Hashtbl.create 8 in + let register_opt_arg_use = function + | (Asttypes.Optional label, Some expr) -> + deferrable_register_use label expr builddir loc !last_loc count_tbl | _ -> () in - List.iter add args - end - + List.iter register_opt_arg_use args (* Verify the nature of the argument to detect and treat function applications and uses *) -and check e = - (* Optional arguments used to match a signature are considered used *) - let get_sig_args typ = - let rec loop args typ = +and register_higher_order_uses builddir e = + (* Optional arguments expected by arrow-typed parameter are considered used + * because they are necessary to match the expected signature *) + let register_opt_args_uses loc typ = + let rec get_labels labels typ = match get_deep_desc typ with - | Tarrow (Asttypes.Optional _ as arg, _, t, _) -> - loop ((arg, Some {e with exp_desc = Texp_constant (Asttypes.Const_int 0)})::args) t - | Tarrow (_, _, t, _) -> loop args t - | _ -> args - in loop [] typ + | Tarrow (arg_label, _, t, _) -> + let labels = + match arg_label with + | Asttypes.Optional label -> label :: labels + | _ -> labels + in + get_labels labels t + | _ -> labels + in + let labels = get_labels [] typ in + let count_tbl = Hashtbl.create 8 in + let register_opt_arg_use label = + deferrable_register_use label e builddir loc !last_loc count_tbl + in + List.iter register_opt_arg_use labels in - match e.exp_desc with - | Texp_ident (_, _, {val_loc = {Location.loc_start=loc; _}; _}) -> - process loc (get_sig_args e.exp_type) - | Texp_apply (exp, _) -> - begin match exp.exp_desc with + | Texp_ident (_, _, {val_loc = {Location.loc_start = loc; _}; _}) -> + register_opt_args_uses loc e.exp_type + | Texp_apply (exp, _) -> ( + match exp.exp_desc with | Texp_ident (_, _, {val_loc = {Location.loc_start = loc; loc_ghost; _}; _}) | Texp_field (_, _, {lbl_loc = {Location.loc_start = loc; loc_ghost; _}; _}) -> - process loc (get_sig_args e.exp_type); - if not loc_ghost then - last_loc := loc + register_opt_args_uses loc e.exp_type; + (* TODO: Why do we want to set last_loc here ? *) + if not loc_ghost then last_loc := loc + | _ -> () + ) + | Texp_let (_, [binding], expr) -> ( + (* Partial application as argument may be cut in two parts: + * [let _ = binding in expr] with [expr] discarding opt args *) + let ( let$ ) x f = Option.iter f x in + let$ ident_loc = + match binding.vb_expr.exp_desc with + | Texp_apply ({exp_desc = Texp_ident (_, _, val_desc); _}, _) + | Texp_ident (_, _, val_desc) -> + Some val_desc.val_loc.loc_start + | _ -> None + in + let$ (c_lhs, c_rhs) = + match expr.exp_desc with + | Texp_function (_, Tfunction_cases {cases = [case]; _}) -> + Some (case.c_lhs, case.c_rhs) + | _ -> None + in + match (c_lhs.pat_desc, c_rhs.exp_desc) with + | (Tpat_var _, Texp_apply (_, args)) -> + if c_lhs.pat_loc.loc_ghost && c_rhs.exp_loc.loc_ghost + && expr.exp_loc.loc_ghost + then register_uses builddir ident_loc args | _ -> () - end - | Texp_let (* Partial application as argument may cut in two parts: - * let _ = partial in implicit opt_args elimination *) - ( _, - [{vb_expr = - { exp_desc = Texp_apply ( - {exp_desc = Texp_ident (_, _, {val_loc = {Location.loc_start = loc; _}; _}); _}, - _) | Texp_ident(_, _, {val_loc = {Location.loc_start = loc; _}; _}); - _}; - _}], - { exp_desc = Texp_function (_, Tfunction_cases { cases = - [{c_lhs = {pat_desc = Tpat_var _; pat_loc = {loc_ghost = true; _}; _}; - c_rhs = {exp_desc = Texp_apply (_, args); exp_loc = {loc_ghost = true; _}; _}; _}]; - _ }); - exp_loc = {loc_ghost = true; _};_}) -> - process loc args + ) | _ -> () +(* redefine without the [builddir] parameter *) +let register_uses val_loc args = + let builddir = + let state = State.get_current () in + State.File_infos.get_builddir state.file_infos + in + register_uses builddir val_loc args -let node_build loc expr = - let rec loop loc expr = - match expr.exp_desc with - | Texp_function (fp, body) -> +let rec bind loc expr = + match expr.exp_desc with + | Texp_function (params, body) -> ( let check_param_style = function | Tparam_pat {pat_type; _} | Tparam_optional_default ({pat_type; _}, _) -> - DeadType.check_style pat_type expr.exp_loc.Location.loc_start + DeadType.check_style pat_type expr.exp_loc.Location.loc_start in let register_optional_param = function - | Asttypes.Optional s when !DeadFlag.optn.print || !DeadFlag.opta.print -> - let opts, next = VdNode.get loc in - VdNode.update loc (s :: opts, next) + | Asttypes.Optional s when DeadFlag.(!optn.print || !opta.print) -> + let (opts, next) = VdNode.get loc in + VdNode.update loc (s :: opts, next) | _ -> () in List.iter @@ -153,37 +172,32 @@ let node_build loc expr = check_param_style fp_kind; register_optional_param fp_arg_label ) - fp; - begin match body with - | Tfunction_body exp -> loop loc exp + params; + match body with + | Tfunction_body exp -> bind loc exp | Tfunction_cases {cases = [{c_lhs = {pat_type; _}; c_rhs = exp; _}]; _} -> - DeadType.check_style pat_type expr.exp_loc.Location.loc_start; - loop loc exp + DeadType.check_style pat_type expr.exp_loc.Location.loc_start; + bind loc exp | _ -> () - end - | Texp_apply (exp, _) -> - begin match exp.exp_desc with - | Texp_ident (_, _, {val_loc = {Location.loc_start = loc2; _}; _}) - | Texp_field (_, _, {lbl_loc = {Location.loc_start = loc2; _}; _}) - when (!DeadFlag.optn.print || !DeadFlag.opta.print) - && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> - VdNode.merge_locs loc loc2 - | _ -> () - end - | Texp_ident (_, _, {val_loc = {Location.loc_start = loc2; _}; _}) - when !DeadFlag.optn.print || !DeadFlag.opta.print - && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> - VdNode.merge_locs loc loc2 - | _ -> () - in loop loc expr - - + ) + | exp_desc + when (!DeadFlag.optn.print || !DeadFlag.opta.print) + && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> + let ( let$ ) x f = Option.iter f x in + let$ loc2 = + match exp_desc with + | Texp_apply ({exp_desc = Texp_ident (_, _, {val_loc = loc; _}); _}, _) + | Texp_apply ({exp_desc = Texp_field (_, _, {lbl_loc = loc; _}); _}, _) + | Texp_ident (_, _, {val_loc = loc; _}) -> + Some loc.loc_start + | _ -> None + in + VdNode.merge_locs loc loc2 + | _ -> () (******** WRAPPING ********) - let wrap f x y = if DeadFlag.(!optn.print || !opta.print) then f x y else () -let process val_loc args = - wrap process val_loc args +let register_uses val_loc args = wrap register_uses val_loc args diff --git a/src/deadArg.mli b/src/deadArg.mli index e312bab..c5b19aa 100644 --- a/src/deadArg.mli +++ b/src/deadArg.mli @@ -7,37 +7,31 @@ (* *) (***************************************************************************) - open Typedtree +val at_eof : (unit -> unit) list ref +(** Functions deferred to run at the end of the current file's analysis. + They reaqire the analysis of future locations in the current file. + It is known that these locations will have been processed at the end + of the binding. + Needed because the Tast_mapper runs through sequences from the end + because tuples are built from right to left. *) +val eof : unit -> unit +(** To use at the end of a [.cmt]'s analysis: + apply [at_eof] functions + reset internal state *) -(* Functions needing a location in the current file to be processed - * before being executed. - * It is known that this location will have been processed at the end of - * the binding. - * Needed because the Tast_mapper run through sequences from the end - * because tuples are built from right to left*) -val later : (unit -> unit) list ref - -(* Functions needing a location out of the current file to be processed - * before being executed. *) -val last : (unit -> unit) list ref - - -(* Self cleaning *) -val eom : - unit -> unit - +val eocb : unit -> unit +(** To use at the end of the codebase analysis: + apply remaining deferred functions which required the analysis of future + locations, their respective files. + [eocb] = end of code base. *) -(* Add all optional arguments met if they are used to match a signature or the location - * is not a ghost and they are part of the application (w/ or w/o value) *) -val process : - Lexing.position - -> (Asttypes.arg_label * expression option) list - -> unit +val register_uses : + Lexing.position -> (Asttypes.arg_label * expression option) list -> unit +(** An optional argument is used if it is required match a signature, or if it + is part of an application (w/ or w/o value) *) -(* Constructs the opt_args field of the given node *) -val node_build : - Lexing.position -> Typedtree.expression -> unit +val bind : Lexing.position -> Typedtree.expression -> unit +(** Bind the opt parameters of expr to the given position *) diff --git a/src/deadCode.ml b/src/deadCode.ml index a0456e1..75f1675 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -62,7 +62,7 @@ let rec treat_exp exp args = | Texp_ident (_, _, {Types.val_loc = {Location.loc_start = loc; _}; _}) | Texp_field (_, _, {lbl_loc = {Location.loc_start = loc; _}; _}) -> - DeadArg.process loc args + DeadArg.register_uses loc args | Texp_match (_, l, _) -> List.iter (fun {c_rhs = exp; _} -> treat_exp exp args) l @@ -78,8 +78,8 @@ let rec treat_exp exp args = let value_binding super self x = - let old_later = !DeadArg.later in - DeadArg.later := []; + let at_eof_saved = !DeadArg.at_eof in + DeadArg.at_eof := []; incr depth; let open Asttypes in begin match x with @@ -105,14 +105,14 @@ let value_binding super self x = vb_expr = exp; _ } -> - DeadArg.node_build loc exp; + DeadArg.bind loc exp; DeadObj.add_var loc exp | _ -> () end; let r = super.Tast_mapper.value_binding self x in - List.iter (fun f -> f()) !DeadArg.later; - DeadArg.later := old_later; + List.iter (fun f -> f()) !DeadArg.at_eof; + DeadArg.at_eof := at_eof_saved; decr depth; r @@ -406,9 +406,9 @@ let clean references loc = if (fn.[String.length fn - 1] <> 'i' && Utils.unit fn = sourceunit) then LocHash.remove references loc -let eom loc_dep = +let eof loc_dep = let state = State.get_current () in - DeadArg.eom(); + DeadArg.eof(); List.iter (assoc decs) loc_dep; List.iter (assoc DeadType.decs) !DeadType.dependencies; let sourcepath = State.File_infos.get_sourcepath state.State.file_infos in @@ -422,8 +422,8 @@ let eom loc_dep = clean loc_dep; clean !DeadType.dependencies; end; - VdNode.eom (); - DeadObj.eom (); + VdNode.eof (); + DeadObj.eof (); DeadType.dependencies := []; Hashtbl.reset incl @@ -480,7 +480,7 @@ let rec load_file state fn = cmt_value_dependencies else [] in - eom loc_dep + eof loc_dep | _ -> () (* todo: support partial_implementation? *) ) @@ -500,7 +500,7 @@ let rec load_file state fn = (* Prepare the list of opt_args for report *) let analyze_opt_args () = - List.iter (fun f -> f ()) !DeadArg.last; + DeadArg.eocb (); let all = ref [] in let tbl = Hashtbl.create 256 in let dec_loc loc = Hashtbl.mem main_files (Utils.unit loc.Lexing.pos_fname) in diff --git a/src/deadCommon.ml b/src/deadCommon.ml index 5ce638b..27466a4 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -298,7 +298,7 @@ module VdNode = struct update loc1 (opts, Some loc2); end - + (* find the loc of the function declaring the nth occurence of the label *) let find loc lab occur = let met = LocHash.create 8 in let rec loop loc lab occur = @@ -306,9 +306,9 @@ module VdNode = struct if is_end loc then 0 else List.filter (( = ) lab) (get_opts loc) |> List.length in - if is_end loc || LocHash.mem met loc || count >= !occur then loc - else begin - occur := !occur - count; + if is_end loc || LocHash.mem met loc || count >= occur then loc + else ( + let occur = occur - count in LocHash.replace met loc (); match get_next loc with | Some next -> loop (func next) lab occur @@ -318,10 +318,10 @@ module VdNode = struct ^ (string_of_int loc.Lexing.pos_lnum) in failwith (loc ^ ": optional argument `" ^ lab ^ "' unlinked") - end + ) in loop (func loc) lab occur - let eom () = + let eof () = let state = State.get_current () in let sons = diff --git a/src/deadObj.ml b/src/deadObj.ml index ca2484b..2c084fc 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -28,7 +28,7 @@ let inheritances = Hashtbl.create 512 (* inheritance links loc-> l let equals = Hashtbl.create 64 -let later = ref [] +let at_eof = ref [] let last_class = ref Lexing.dummy_pos (* last class met *) @@ -160,7 +160,7 @@ let locate expr = in repr_exp expr locate -let eom () = +let eof () = Hashtbl.reset defined; last_class := Lexing.dummy_pos @@ -318,7 +318,7 @@ let class_field f = add_equal f.cf_loc.Location.loc_start cl_exp.cl_loc.Location.loc_start; let loc = get_loc path in let equal () = add_equal cl_exp.cl_loc.Location.loc_start (get_loc path) in (* for uses inside class def *) - if loc == Lexing.dummy_pos then later := equal :: !later + if loc == Lexing.dummy_pos then at_eof := equal :: !at_eof else equal () end; List.iter (fun (s, _) -> update_overr false s) l @@ -376,7 +376,7 @@ let coerce expr typ = let prepare_report () = - List.iter (fun f -> f ()) !later; + List.iter (fun f -> f ()) !at_eof; let apply_self meth loc1 loc2 = let loc1 = repr_loc loc1 diff --git a/src/deadObj.mli b/src/deadObj.mli index 1eb3ab3..1602d8c 100644 --- a/src/deadObj.mli +++ b/src/deadObj.mli @@ -60,8 +60,8 @@ val coerce: expression -> Types.type_expr -> unit -val eom : - unit -> unit +val eof : unit -> unit +(** For use at the end of a [.cmt]'s analysis: reset internal state *) val report : diff --git a/src/deadType.ml b/src/deadType.ml index 3649cfe..2902b1b 100644 --- a/src/deadType.ml +++ b/src/deadType.ml @@ -42,43 +42,9 @@ let nb_args ~keep typ = loop 0 (get_desc typ) -let rec _TO_STRING_ typ = begin [@warning "-11"] match get_deep_desc typ with - | Tvar i -> begin match i with Some id -> id | None -> "'a" end - | Tarrow (_, t1, t2, _) -> - begin match get_deep_desc t1 with - | Tarrow _ -> "(" ^ _TO_STRING_ t1 ^ ")" - | _ -> _TO_STRING_ t1 end - ^ " -> " ^ _TO_STRING_ t2 - | Ttuple l -> begin match l with - | e::l -> - List.fold_left (fun prev typ -> prev ^ " * " ^ _TO_STRING_ typ) (_TO_STRING_ e) l - | [] -> "*" end - | Tconstr (path, l, _) -> make_name path l - | Tobject (self, _) -> "< " ^ _TO_STRING_ self ^ " >" - | Tfield (s, k, _, t1) -> - if field_kind_repr k <> Fabsent then - s - ^ begin match get_deep_desc t1 with - | Tfield _ -> "; " ^ _TO_STRING_ t1 - | _ -> "" end - else _TO_STRING_ t1 - | Tnil -> "Tnil" - | Tlink t -> _TO_STRING_ t - | Tsubst _ -> "Tsubst _" - | Tvariant r -> _TO_STRING_ (row_more r) - | Tunivar _ -> "Tunivar _" - | Tpoly (t, _) -> _TO_STRING_ t - | Tpackage _ -> "Tpackage _" - | _ -> "Extension _" end - - -and make_name path l = - let t = match l with - | [] -> "" - | _ -> List.fold_left (fun prev typ -> prev ^ _TO_STRING_ typ ^ " ") "" l; - in - let name = Path.name path in - t ^ name +let to_string typ = + Printtyp.type_expr Format.str_formatter typ; + Format.flush_str_formatter () let is_type s = @@ -121,7 +87,7 @@ let collect_export path u stock t = List.iter (fun {Types.ld_id; ld_loc; ld_type; _} -> save ld_id ld_loc; - !DeadLexiFi.export_type ld_loc.Location.loc_start (_TO_STRING_ ld_type) + !DeadLexiFi.export_type ld_loc.Location.loc_start (to_string ld_type) ) l | Type_variant (l, _) -> @@ -191,7 +157,7 @@ let tstr typ = | Ttype_record l -> List.iter (fun {Typedtree.ld_name; ld_loc; ld_type; _} -> - assoc ld_name ld_loc.Location.loc_start (_TO_STRING_ ld_type.ctyp_type) + assoc ld_name ld_loc.Location.loc_start (to_string ld_type.ctyp_type) ) l | Ttype_variant l -> diff --git a/src/deadType.mli b/src/deadType.mli index 47f1737..28eed7b 100644 --- a/src/deadType.mli +++ b/src/deadType.mli @@ -11,8 +11,8 @@ val decs : (Lexing.position, string * string) Hashtbl.t val dependencies : (Lexing.position * Lexing.position) list ref -val _TO_STRING_ : Types.type_expr -> string - (** [_TO_STRING_ typ] converts [typ] to its string representation in the toplevel *) +val to_string : Types.type_expr -> string + (** [to_string typ] converts [typ] to its string representation in the toplevel *) val check_style : Types.type_expr -> Lexing.position -> unit (** Look for bad style typing. (i.e. Argument expecting an optional argument) *)