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   List.iter (fun uu ->
  45      indent := 0;
  46 (*     prerr_endline ("************* INIZIO **************** " ^ NUri.string_of_uri uu); *)
  47     let _,o = NCicEnvironment.get_obj uu in
  48     try
  49       NCicTypeChecker.typecheck_obj o;
  50 (*       prerr_endline ("************* FINE ****************" ^ NUri.string_of_uri uu); *)
  51     with
  52     | NCicTypeChecker.AssertFailure s
  53     | NCicTypeChecker.TypeCheckerFailure s as e ->
  54 (*        prerr_endline ("Obj: " ^ NCicPp.ppobj o); *)
  55        prerr_endline ("######### " ^ Lazy.force s); raise e
  56     | CicEnvironment.Object_not_found s ->
  57                     prerr_endline ("Obj not found: " ^ UriManager.string_of_uri s);
  58     )
  59     alluris;
  60   NCicEnvironment.invalidate ();
  61   Gc.compact ();
  62   prerr_endline "typechecking, first with the new and then with the old kernel";
  63   let prima = Unix.gettimeofday () in
  64   List.iter
  65     (fun u ->
  66       indent := 0;
  67       NCicTypeChecker.typecheck_obj (snd (NCicEnvironment.get_obj u)))
  68     alluris;
  69   let dopo = Unix.gettimeofday () in
  70   Gc.compact ();
  71   let dopo2 = Unix.gettimeofday () in
  72   Printf.eprintf "NEW typing: %3.2f, gc: %3.2f\n%!" (dopo -. prima) (dopo2 -.  dopo);
  73   CicEnvironment.invalidate ();
  74   let alluris = List.map NUri.ouri_of_nuri alluris in
  75   Gc.compact ();
  76   let prima = Unix.gettimeofday () in
  77   List.iter (fun u -> ignore (CicTypeChecker.typecheck u)) alluris;
  78   let dopo = Unix.gettimeofday () in
  79   Gc.compact ();
  80   let dopo2 = Unix.gettimeofday () in
  81   Printf.eprintf "OLD typing: %3.2f, gc: %3.2f\n%!" (dopo -. prima) (dopo2 -. dopo)
  82 ;;