Add -debug-backtrace

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

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

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

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>Error@}: %s\n" Loc.print loc msg
-  | Fatal_error "" -> ()
+    Format.fprintf ppf "%a@{<error>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>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 "@{<error>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>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>Error@}: exception %s\nBacktrace:\n%s" s bt
+      Format.fprintf ppf "@{<error>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