diff --git a/bin/main.ml b/bin/main.ml index 9b463d78..f338a8c5 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -9,18 +9,19 @@ let () = suggest_function := Jbuilder_cmdliner.Cmdliner_suggest.value let (>>=) = Future.(>>=) type common = - { concurrency : int - ; debug_dep_path : bool - ; debug_findlib : bool - ; dev_mode : bool - ; verbose : bool - ; workspace_file : string option - ; root : string - ; target_prefix : string - ; only_packages : String_set.t option - ; capture_outputs : bool + { concurrency : int + ; debug_dep_path : bool + ; debug_findlib : bool + ; debug_backtraces : bool + ; dev_mode : bool + ; verbose : bool + ; workspace_file : string option + ; root : string + ; target_prefix : string + ; only_packages : String_set.t option + ; capture_outputs : bool ; (* Original arguments for the external-lib-deps hint *) - orig_args : string list + orig_args : string list } let prefix_target common s = common.target_prefix ^ s @@ -29,6 +30,7 @@ let set_common c ~targets = Clflags.concurrency := c.concurrency; Clflags.debug_dep_path := c.debug_dep_path; Clflags.debug_findlib := c.debug_findlib; + Clflags.debug_backtraces := c.debug_backtraces; Clflags.dev_mode := c.dev_mode; Clflags.verbose := c.verbose; Clflags.capture_outputs := c.capture_outputs; @@ -109,6 +111,7 @@ let common = concurrency debug_dep_path debug_findlib + debug_backtraces dev_mode verbose no_buffer @@ -130,6 +133,7 @@ let common = { concurrency ; debug_dep_path ; debug_findlib + ; debug_backtraces ; dev_mode ; verbose ; capture_outputs = not no_buffer @@ -176,6 +180,12 @@ let common = & info ["debug-findlib"] ~docs ~doc:{|Debug the findlib sub-system.|}) in + let dbacktraces = + Arg.(value + & flag + & info ["debug-backtraces"] ~docs + ~doc:{|Always print exception backtraces.|}) + in let dev = Arg.(value & flag @@ -261,6 +271,7 @@ let common = $ concurrency $ ddep_path $ dfindlib + $ dbacktraces $ dev $ verbose $ no_buffer diff --git a/src/clflags.ml b/src/clflags.ml index 7be1d7e7..2e789c8c 100644 --- a/src/clflags.ml +++ b/src/clflags.ml @@ -9,3 +9,4 @@ let dev_mode = ref false let workspace_root = ref "." let external_lib_deps_hint = ref [] let capture_outputs = ref true +let debug_backtraces = ref false diff --git a/src/clflags.mli b/src/clflags.mli index 44c6bbae..2aa9bacf 100644 --- a/src/clflags.mli +++ b/src/clflags.mli @@ -32,3 +32,6 @@ val external_lib_deps_hint : string list ref (** Capture the output of sub-commands *) val capture_outputs : bool ref + +(** Always print backtraces, to help debugging jbuilder itself *) +val debug_backtraces : bool ref diff --git a/src/main.ml b/src/main.ml index 5c140271..2e0b380c 100644 --- a/src/main.ml +++ b/src/main.ml @@ -75,6 +75,7 @@ let external_lib_deps ?log ~packages () = ~f:(String_map.filter ~f:(fun name _ -> not (String_set.mem name internals)))) +(* Return [true] if the backtrace was printed *) let report_error ?(map_fname=fun x->x) ppf exn ~backtrace = match exn with | Loc.Error (loc, msg) -> @@ -83,10 +84,12 @@ let report_error ?(map_fname=fun x->x) ppf exn ~backtrace = start = { loc.start with pos_fname = map_fname loc.start.pos_fname } } in - Format.fprintf ppf "%a@{Error@}: %s\n" Loc.print loc msg - | Fatal_error "" -> () + Format.fprintf ppf "%a@{Error@}: %s\n" Loc.print loc msg; + false + | Fatal_error "" -> false | Fatal_error msg -> - Format.fprintf ppf "%s\n" (String.capitalize_ascii msg) + Format.fprintf ppf "%s\n" (String.capitalize_ascii msg); + false | Findlib.Package_not_available { package; required_by; reason } -> Format.fprintf ppf "@{Error@}: External library %S %s.\n" package @@ -114,7 +117,8 @@ let report_error ?(map_fname=fun x->x) ppf exn ~backtrace = Format.fprintf ppf "Hint: try: %s\n" (List.map !Clflags.external_lib_deps_hint ~f:quote_for_shell - |> String.concat ~sep:" ") + |> String.concat ~sep:" "); + false | Findlib.External_dep_conflicts_with_local_lib { package; required_by; required_locally_in; defined_locally_in } -> Format.fprintf ppf @@ -127,37 +131,53 @@ let report_error ?(map_fname=fun x->x) ppf exn ~backtrace = (Utils.jbuild_name_in ~dir:(Path.drop_build_context defined_locally_in)) required_by required_by - (Utils.jbuild_name_in ~dir:required_locally_in) + (Utils.jbuild_name_in ~dir:required_locally_in); + false | Code_error msg -> let bt = Printexc.raw_backtrace_to_string backtrace in Format.fprintf ppf "@{Internal error, please report upstream \ including the contents of _build/log.@}\n\ Description: %s\n\ Backtrace:\n\ - %s" msg bt + %s" msg bt; + true | Unix.Unix_error (err, func, fname) -> Format.fprintf ppf "@{Error@}: %s: %s: %s\n" - func fname (Unix.error_message err) + func fname (Unix.error_message err); + false | _ -> let s = Printexc.to_string exn in let bt = Printexc.raw_backtrace_to_string backtrace in if String.is_prefix s ~prefix:"File \"" then Format.fprintf ppf "%s\nBacktrace:\n%s" s bt else - Format.fprintf ppf "@{Error@}: exception %s\nBacktrace:\n%s" s bt + Format.fprintf ppf "@{Error@}: exception %s\nBacktrace:\n%s" s bt; + true let report_error ?map_fname ppf exn = - match exn with - | Build_system.Build_error.E err -> - let module E = Build_system.Build_error in - report_error ?map_fname ppf (E.exn err) ~backtrace:(E.backtrace err); - if !Clflags.debug_dep_path then - Format.fprintf ppf "Dependency path:\n %s\n" - (String.concat ~sep:"\n--> " - (List.map (E.dependency_path err) ~f:Utils.describe_target)) - | exn -> - let backtrace = Printexc.get_raw_backtrace () in - report_error ?map_fname ppf exn ~backtrace + match + match exn with + | Build_system.Build_error.E err -> + let module E = Build_system.Build_error in + let backtrace = E.backtrace err in + let bt_printed = + report_error ?map_fname ppf (E.exn err) ~backtrace:(E.backtrace err) + in + if !Clflags.debug_dep_path then + Format.fprintf ppf "Dependency path:\n %s\n" + (String.concat ~sep:"\n--> " + (List.map (E.dependency_path err) ~f:Utils.describe_target)); + Option.some_if (not bt_printed) backtrace + | exn -> + let backtrace = Printexc.get_raw_backtrace () in + let bt_printed = + report_error ?map_fname ppf exn ~backtrace + in + Option.some_if (not bt_printed) backtrace + with + | Some bt when !Clflags.debug_backtraces -> + Format.fprintf ppf "Backtrace:\n%s" (Printexc.raw_backtrace_to_string bt) + | _ -> () let ignored_during_bootstrap = Path.Set.of_list