Init progress

(* init_info.ml
 * ./ocamlopt ... dynlink.cmxa init_info.ml ...
 *  Uncaught exception during initialization:
 *    CamlinternalFormatBasics
 *    Pervasives
 *    ...
 *    Dynlink
 *    Init_info
 *    A
 * => B
 *    Std_exit
 * Exception: Failure("Argh")
 *)
external ndl_getmap: unit -> bytes = "caml_natdynlink_getmap"
external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited"
external reraise: exn -> 'a = "%reraise"

let init_list : string list lazy_t =
  lazy begin
    let map : (string*Digest.t*Digest.t*string list) list =
      Marshal.from_bytes (ndl_getmap ()) 0 in
    List.concat (List.map (fun (_,_,_,syms) -> syms) map)
  end

let get_init_progress () : string list * string list =
  let lazy all = init_list and current = ndl_globals_inited () in
  let rec aux acc n = function
   | x :: xs when n > 0 -> aux (x :: acc) (n - 1) xs
   | xs -> List.rev acc, xs
  in
  aux [] current all

let prerr_init_progress () =
  let finished, todo = get_init_progress () in
  let prerr_item sym = prerr_string "   "; prerr_endline sym in
  List.iter prerr_item finished;
  match todo with
  | [] -> ()
  | x :: xs ->
      prerr_string "=> ";
      prerr_endline x;
      List.iter prerr_item xs

let init_handler exn backtrace =
  prerr_endline "Uncaught exception during initialization:";
  prerr_init_progress ();
  prerr_endline ("Exception: " ^ Printexc.to_string exn);
  Printexc.print_raw_backtrace stderr backtrace

let () = Printexc.set_uncaught_exception_handler init_handler