Use reraise to remove Misc.fatal_error_callstack, revert Fatal_error …

…handling in Misc to 4.12 state (#521)

middle_end/flambda/flambda_middle_end.ml

@@ -107,28 +107,20 @@ let middle_end0 ppf ~prefixname ~backend ~filename ~module_ident
 
 let middle_end ~ppf_dump:ppf ~prefixname ~backend ~filename ~module_ident
       ~module_block_size_in_words ~module_initializer : middle_end_result =
-  try
-    let simplify_result =
-      middle_end0 ppf ~prefixname ~backend ~filename ~module_ident
-        ~module_block_size_in_words ~module_initializer
-    in
-    begin match Sys.getenv "PRINT_SIZES" with
-    | exception Not_found -> ()
-    | _ ->
-      Exported_code.iter simplify_result.all_code (fun id code ->
-        let size = Flambda.Code.cost_metrics code in
-        Format.fprintf Format.std_formatter "%a %a\n"
-          Code_id.print id Flambda.Cost_metrics.print size
-      )
-    end;
-    { cmx = simplify_result.cmx;
-      unit = simplify_result.unit;
-      all_code = simplify_result.all_code;
-    }
-  with Misc.Fatal_error -> begin
-    Format.eprintf "\n%sOriginal backtrace is:%s\n%s\n"
-      (Flambda_colours.error ())
-      (Flambda_colours.normal ())
-      (Printexc.raw_backtrace_to_string (Misc.fatal_error_callstack ()));
-    raise Misc.Fatal_error
-  end
+  let simplify_result =
+    middle_end0 ppf ~prefixname ~backend ~filename ~module_ident
+      ~module_block_size_in_words ~module_initializer
+  in
+  begin match Sys.getenv "PRINT_SIZES" with
+  | exception Not_found -> ()
+  | _ ->
+    Exported_code.iter simplify_result.all_code (fun id code ->
+      let size = Flambda.Code.cost_metrics code in
+      Format.fprintf Format.std_formatter "%a %a\n"
+        Code_id.print id Flambda.Cost_metrics.print size
+    )
+  end;
+  { cmx = simplify_result.cmx;
+    unit = simplify_result.unit;
+    all_code = simplify_result.all_code;
+  }

middle_end/flambda/from_lambda/closure_conversion.ml

@@ -696,6 +696,8 @@ let close_switch acc env scrutinee (sw : IR.switch)
         untag ~body ~free_names_of_body:Unknown
       |> Expr_with_acc.create_let
 
+external reraise : exn -> 'a = "%reraise"
+
 let close_one_function acc ~external_env ~by_closure_id decl
       ~var_within_closures_from_idents ~closure_ids_from_idents
       function_declarations =
@@ -802,7 +804,7 @@ let close_one_function acc ~external_env ~by_closure_id decl
           Closure_id.print closure_id
           (* print body *)
       end;
-      raise Misc.Fatal_error
+      reraise Misc.Fatal_error
     end
   in
   let contains_subfunctions = Acc.seen_a_function acc in

middle_end/flambda/simplify/simplify_named.ml

@@ -136,6 +136,8 @@ let record_any_symbol_projection dacc (defining_expr : Simplified_named.t)
     let var = Var_in_binding_pos.var bound_var in
     DA.map_denv dacc ~f:(fun denv -> DE.add_symbol_projection denv var proj)
 
+external reraise : exn -> 'a = "%reraise"
+
 (* It is important that every set of closures returned by this function
    (in [bindings_outermost_first]) arises from simplification in
    [Simplify_set_of_closures], and not some other path such as reification.
@@ -243,7 +245,7 @@ let simplify_named0 dacc (bindable_let_bound : Bindable_let_bound.t)
             Bound_symbols.print bound_symbols
             DA.print dacc
           end;
-          raise Misc.Fatal_error
+          reraise Misc.Fatal_error
       end
     in
     let dacc, lifted_constants =
@@ -378,6 +380,8 @@ let removed_operations (named : Named.t) result =
     end
   | Rec_info _ -> zero
 
+external reraise : exn -> 'a = "%reraise"
+
 let simplify_named dacc bindable_let_bound named ~simplify_toplevel =
   try
     let simplified_named =
@@ -394,5 +398,5 @@ let simplify_named dacc bindable_let_bound named ~simplify_toplevel =
         Named.print named
         DA.print dacc
     end;
-    raise Misc.Fatal_error
+    reraise Misc.Fatal_error
   end

middle_end/flambda/simplify/simplify_set_of_closures.ml

@@ -349,6 +349,8 @@ let dacc_inside_function context ~used_closure_vars ~shareable_constants
   |> DA.with_shareable_constants ~shareable_constants
   |> DA.with_used_closure_vars ~used_closure_vars
 
+external reraise : exn -> 'a = "%reraise"
+
 type simplify_function_result = {
   function_decl : FD.t;
   new_code_id : Code_id.t;
@@ -466,7 +468,7 @@ let simplify_function context ~used_closure_vars ~shareable_constants
               Expr.print body
               DA.print dacc
           end;
-          raise Misc.Fatal_error)
+          reraise Misc.Fatal_error)
   in
   let cost_metrics = UA.cost_metrics uacc_after_upwards_traversal in
   let old_code_id = code_id in

middle_end/flambda/simplify/typing_helpers/continuation_uses.ml

@@ -44,6 +44,8 @@ let print ppf { continuation; arity; uses; } =
     Flambda_arity.print arity
     (Format.pp_print_list ~pp_sep:Format.pp_print_space U.print) uses
 
+external reraise : exn -> 'a = "%reraise"
+
 let add_use t kind ~env_at_use id ~arg_types =
   try
     let arity = T.arity_of_list arg_types in
@@ -68,7 +70,7 @@ let add_use t kind ~env_at_use id ~arg_types =
         print t
         DE.print env_at_use
     end;
-    raise Misc.Fatal_error
+    reraise Misc.Fatal_error
   end
 
 let union t1 t2 =

middle_end/flambda/types/env/typing_env.rec.ml

@@ -1252,6 +1252,8 @@ let cut_and_n_way_join definition_typing_env ts_and_use_ids ~params
   in
   add_env_extension_from_level definition_typing_env level
 
+external reraise : exn -> 'a = "%reraise"
+
 let type_simple_in_term_exn t ?min_name_mode simple =
   (* If [simple] is a variable then it should not come from a missing .cmx
      file, since this function is only used for typing variables in terms,
@@ -1321,7 +1323,7 @@ let type_simple_in_term_exn t ?min_name_mode simple =
         (Flambda_colours.normal ())
         print t
     end;
-    raise Misc.Fatal_error
+    reraise Misc.Fatal_error
   | alias -> Type_grammar.alias_type_of kind alias
 
 let get_canonical_simple_exn t ?min_name_mode ?name_mode_of_existing_simple
@@ -1403,7 +1405,7 @@ let get_canonical_simple_exn t ?min_name_mode ?name_mode_of_existing_simple
         (Flambda_colours.normal ())
         print t
     end;
-    raise Misc.Fatal_error
+    reraise Misc.Fatal_error
   | alias -> alias
 
 let get_alias_then_canonical_simple_exn t ?min_name_mode

utils/misc.ml

@@ -191,19 +191,14 @@ end
 
 exception Fatal_error
 
-let fatal_error_callstack = ref (Printexc.get_callstack 1)
-
 let fatal_errorf fmt =
-  fatal_error_callstack := Printexc.get_callstack 1000;
   Format.kfprintf
     (fun _ -> raise Fatal_error)
     Format.err_formatter
-    ("@?@{<error>>> Fatal error: @}" ^^ fmt ^^ "@.")
+    ("@?>> Fatal error: " ^^ fmt ^^ "@.")
 
 let fatal_error msg = fatal_errorf "%s" msg
 
-let fatal_error_callstack () = !fatal_error_callstack
-
 (* Exceptions *)
 
 let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work =

utils/misc.mli

@@ -24,8 +24,6 @@ val fatal_error: string -> 'a
 val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
 exception Fatal_error
 
-val fatal_error_callstack : unit -> Printexc.raw_backtrace
-
 val try_finally :
   ?always:(unit -> unit) ->
   ?exceptionally:(unit -> unit) ->