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