tighten up Printexc.get_backtrace 6

Summary:
This diff tightens up Printexc.backtrace in the last place that called Hh_logger.exc_with_dodgy_backtrace. I think the Core_utils.try_with function has a design that makes safe callstacks impossible. I have therefore changed us to use Utils.try_with_stack, which preserves the callstack at moment of catching exception.

(I'd have liked to mark Core_result.try_with as DEPRECATED, but I dont want to alter something that comes from Core).

Reviewed By: arxanas

Differential Revision: D10162683

fbshipit-source-id: 2abe28764005fa36602e1f52f9d3d20b8f76b4e7

hphp/hack/src/server/saveStateService.ml

@@ -177,9 +177,9 @@ let save_state
     update_save_state ~file_info_on_disk files_info errors output_filename
 
 let get_in_memory_dep_table_entry_count () : (int, string) result =
-  Core_result.try_with (fun () ->
+  Utils.try_with_stack (fun () ->
     SharedMem.get_in_memory_dep_table_entry_count ())
-  |> Core_result.map_error ~f:Printexc.to_string
+  |> Core_result.map_error ~f:(fun (exn, _stack) -> Printexc.to_string exn)
 
 (* If successful, returns the # of edges from the dependency table that were written. *)
 (* TODO: write some other stats, e.g., the number of names, the number of errors, etc. *)
@@ -188,6 +188,6 @@ let go
     (files_info: FileInfo.t Relative_path.Map.t)
     (errors: Errors.t)
     (output_filename: string) : (int, string) result =
-  Core_result.try_with (fun () ->
+  Utils.try_with_stack (fun () ->
     save_state ~file_info_on_disk files_info errors output_filename)
-  |> Core_result.map_error ~f:Printexc.to_string
+  |> Core_result.map_error ~f:(fun (exn, _stack) -> Printexc.to_string exn)

hphp/hack/src/server/serverUtils.ml

@@ -51,8 +51,8 @@ let connect_to_monitor ~timeout root =
   MC.connect_once ~timeout (hh_monitor_config root)
 
 let print_hash_stats () =
-  Core_result.try_with SharedMem.dep_stats
-  |> Core_result.map_error ~f:Hh_logger.exc_with_dodgy_backtrace
+  Utils.try_with_stack SharedMem.dep_stats
+  |> Core_result.map_error ~f:(fun (exn, Utils.Callstack stack) -> Hh_logger.exc ~stack exn)
   |> Core_result.iter ~f:begin fun { SharedMem.
     used_slots;
     slots;
@@ -61,8 +61,8 @@ let print_hash_stats () =
     Hh_logger.log "Dependency table load factor: %d / %d (%.02f)"
       used_slots slots load_factor
   end;
-  Core_result.try_with SharedMem.hash_stats
-  |> Core_result.map_error ~f:Hh_logger.exc_with_dodgy_backtrace
+  Utils.try_with_stack SharedMem.hash_stats
+  |> Core_result.map_error ~f:(fun (exn, Utils.Callstack stack) -> Hh_logger.exc ~stack exn)
   |> Core_result.iter ~f:begin fun { SharedMem.
     used_slots;
     slots;

hphp/hack/src/utils/hh_logger.ml

@@ -38,12 +38,6 @@ let print_duration name t =
   print_with_newline "%s: %f" name (t2 -. t);
   t2
 
-let exc_with_dodgy_backtrace ?(prefix: string = "") (e: exn) : unit =
-  (* TODO - delete this function and use call normal Hh_logger functions with ~exn *)
-  print_with_newline "%s%s" prefix (Printexc.to_string e);
-  Printexc.print_backtrace stderr;
-  ()
-
 let exc ?(prefix: string = "") ~(stack: string) (e: exn) : unit =
   print_with_newline "%s%s\n%s" prefix (Printexc.to_string e) stack
 

hphp/hack/src/utils/utils.ml

@@ -9,6 +9,9 @@
 
 open Hh_core
 
+(** Callstack is simply a typed way to indicate that a string is a callstack *)
+type callstack = Callstack of string
+
 let () = Random.self_init ()
 let debug = ref false
 let profile = ref false
@@ -110,7 +113,7 @@ let is_prefix_dir dir fn =
   String.length fn > String.length prefix &&
   String.sub fn 0 (String.length prefix) = prefix
 
-let try_with_channel oc f1 f2 =
+let try_with_channel (oc: out_channel) (f1: out_channel -> 'a) (f2: exn -> 'a) : 'a =
   try
     let result = f1 oc in
     close_out oc;
@@ -119,6 +122,14 @@ let try_with_channel oc f1 f2 =
     close_out oc;
     f2 e
 
+let try_with_stack (f: unit -> 'a) : ('a, exn * callstack) result =
+  try
+    Ok (f ())
+  with exn ->
+    let stack = Callstack (Printexc.get_backtrace ()) in
+    Error (exn, stack)
+
+
 let iter_n_acc n f acc =
   let acc = ref acc in
   for i = 1 to n-1 do
@@ -212,9 +223,6 @@ let infimum (arr : 'a array)
   end in
   binary_search 0 ((Array.length arr) - 1)
 
-(** Callstack is simply a typed way to indicate that a string is a callstack *)
-type callstack = Callstack of string
-
 let unwrap_snd (a, b_opt) =
   match b_opt with
   | None -> None