helm/software/components/ng_kernel/check.ml

   1 let _ =
   2   let indent = ref 0 in
   3 (*   let do_indent () = String.make !indent ' ' in *)
   4    NCicTypeChecker.set_logger
   5     (function
   6     | `Start_type_checking s -> ();
   7 (*        prerr_endline (do_indent () ^ "Start: " ^ NUri.string_of_uri s);
   8         incr indent
   9 *)
  10     | `Type_checking_completed s ->  ();
  11 (*
  12         decr indent;
  13         prerr_endline (do_indent () ^ "End: " ^ NUri.string_of_uri s)
  14 *)
  15        );
  16   NCicPp.set_ppterm NCicPp.trivial_pp_term;
  17   Helm_registry.load_from "conf.xml";
  18   let alluris =
  19     try
  20       let s = Sys.argv.(1) in
  21       if s = "-alluris" then
  22        begin
  23         let uri_re = Str.regexp ".*\\(ind\\|con\\)$" in
  24         let uris = Http_getter.getalluris () in
  25         let alluris = List.filter (fun u -> Str.string_match uri_re u 0) uris in
  26         let oc = open_out "alluris.txt" in
  27         List.iter (fun s -> output_string oc (s^"\n")) alluris;
  28         close_out oc;
  29         []
  30        end
  31       else [s]
  32     with Invalid_argument _ ->
  33       let r = ref [] in
  34       let ic = open_in "alluris.txt" in
  35       try while true do r := input_line ic :: !r; done; []
  36       with _ -> List.rev !r
  37   in
  38   let alluris =
  39     HExtlib.filter_map
  40       (fun u -> try Some (NUri.nuri_of_ouri (UriManager.uri_of_string u)) with _
  41       -> None) alluris
  42   in
  43   prerr_endline "caching objects";
  44   HExtlib.profiling_enabled := false;
  45   List.iter (fun uu ->
  46      indent := 0;
  47 (*     prerr_endline ("************* INIZIO **************** " ^ NUri.string_of_uri uu); *)
  48     let _,o = NCicEnvironment.get_obj uu in
  49     try
  50       NCicTypeChecker.typecheck_obj o;
  51 (*       prerr_endline ("************* FINE ****************" ^ NUri.string_of_uri uu); *)
  52     with
  53     | NCicTypeChecker.AssertFailure s
  54     | NCicTypeChecker.TypeCheckerFailure s as e ->
  55 (*        prerr_endline ("Obj: " ^ NCicPp.ppobj o); *)
  56        prerr_endline ("######### " ^ Lazy.force s); raise e
  57     | CicEnvironment.Object_not_found s ->
  58                     prerr_endline ("Obj not found: " ^ UriManager.string_of_uri s);
  59     )
  60     alluris;
  61   NCicEnvironment.invalidate ();
  62   Gc.compact ();
  63   HExtlib.profiling_enabled := true;
  64   prerr_endline "typechecking, first with the new and then with the old kernel";
  65   let prima = Unix.gettimeofday () in
  66   List.iter
  67     (fun u ->
  68       indent := 0;
  69       NCicTypeChecker.typecheck_obj (snd (NCicEnvironment.get_obj u)))
  70     alluris;
  71   let dopo = Unix.gettimeofday () in
  72   Gc.compact ();
  73   let dopo2 = Unix.gettimeofday () in
  74   Printf.eprintf "NEW typing: %3.2f, gc: %3.2f\n%!" (dopo -. prima) (dopo2 -.  dopo);
  75   CicEnvironment.invalidate ();
  76   let alluris = List.map NUri.ouri_of_nuri alluris in
  77   Gc.compact ();
  78   let prima = Unix.gettimeofday () in
  79   List.iter (fun u -> ignore (CicTypeChecker.typecheck u)) alluris;
  80   let dopo = Unix.gettimeofday () in
  81   Gc.compact ();
  82   let dopo2 = Unix.gettimeofday () in
  83   Printf.eprintf "OLD typing: %3.2f, gc: %3.2f\n%!" (dopo -. prima) (dopo2 -. dopo)
  84 ;;