]> matita.cs.unibo.it Git - helm.git/blobdiff - helm/software/components/library/librarian.ml
removed debug pps
[helm.git] / helm / software / components / library / librarian.ml
index aa6b2e81dd2e3997f96d41669e7ff245fc50e306..9b08f46145c6879a745aa9de619d6a1e84cdd4da 100644 (file)
@@ -1,4 +1,40 @@
-let debug = false;;
+(* Copyright (C) 2005, HELM Team.
+ * 
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ * 
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ * 
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA  02111-1307, USA.
+ * 
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+let debug = ref false
+
+let time_stamp =
+   let old = ref 0.0 in
+   fun msg -> 
+      if !debug then begin
+         let times = Unix.times () in
+         let stamp = times.Unix.tms_utime +. times.Unix.tms_stime in
+         let lap = stamp -. !old in
+         Printf.eprintf "TIME STAMP (%s): %f\n" msg lap; flush stderr;
+         old := stamp
+      end
 
 exception NoRootFor of string
 
@@ -52,7 +88,7 @@ let load_root_file rootpath =
     lines
 ;;
 
-let find_root_for ~include_paths file = 
+let rec find_root_for ~include_paths file = 
  let include_paths = "" :: Sys.getcwd () :: include_paths in
  try 
    let path = HExtlib.find_in include_paths file in
@@ -76,10 +112,16 @@ let find_root_for ~include_paths file =
      HLog.error (rootpath ^ " sets an incorrect baseuri: " ^ buri);
    ensure_trailing_slash root, remove_trailing_slash uri, path
  with Failure "find_in" -> 
-   HLog.error ("We are in: " ^ Sys.getcwd ());
-   HLog.error ("Unable to find: "^file^"\nPaths explored:");
-   List.iter (fun x -> HLog.error (" - "^x)) include_paths;
-   raise (NoRootFor file)
+   if Filename.check_suffix file ".ma" then begin
+      let mma = Filename.chop_suffix file ".ma" ^ ".mma" in
+      HLog.warn ("We look for: " ^ mma);
+      find_root_for ~include_paths mma
+   end else begin
+      HLog.error ("We are in: " ^ Sys.getcwd ());
+      HLog.error ("Unable to find: "^file^"\nPaths explored:");
+      List.iter (fun x -> HLog.error (" - "^x)) include_paths;
+      raise (NoRootFor file)
+   end
 ;;
 
 let mk_baseuri root extra =
@@ -153,16 +195,22 @@ module type Format =
     val mtime_of_source_object: source_object -> float option
     val mtime_of_target_object: target_object -> float option
     val is_readonly_buri_of: options -> source_object -> bool
-    val dotdothack: source_object -> source_object 
   end
 
 module Make = functor (F:Format) -> struct
 
-  let say s = if debug then prerr_endline ("make: "^s);; 
+  type status = Done of bool
+              | Ready of bool
+
+  let say s = if !debug then prerr_endline ("make: "^s);; 
 
   let unopt_or_call x f y = match x with Some _ -> x | None -> f y;;
 
-  let younger_s_t (_,cs,ct) a b = 
+  let fst4 = function (x,_,_,_) -> x;;
+
+  let modified_before_s_t (_,cs, ct, _, _) a b = 
+    prerr_endline ("L s_t: a " ^ F.string_of_source_object a);
+    prerr_endline ("L s_t: b " ^ F.string_of_target_object b);  
     let a = try Hashtbl.find cs a with Not_found -> assert false in
     let b = 
       try
@@ -176,20 +224,24 @@ module Make = functor (F:Format) -> struct
            | x -> x
       with Not_found -> assert false
     in
-    match a, b with 
-    | Some a, Some b -> a < b
-    | _ -> false
-  ;;
+    let r = match a, b with 
+       | Some a, Some b -> a <= b
+       | _ -> false
+    in
+    prerr_endline ("L s_t: " ^ string_of_bool r); r
 
-  let younger_t_t (_,_,ct) a b = 
-    let a = 
+  let modified_before_t_t (_,_,ct, _, _) a b = 
+(*    
+    prerr_endline ("L t_t: a " ^ F.string_of_target_object a);
+    prerr_endline ("L t_t: b " ^ F.string_of_target_object b);
+*)    let a = 
       try
         match Hashtbl.find ct a with
         | Some _ as x -> x
         | None ->
-           match F.mtime_of_target_object a with
+          match F.mtime_of_target_object a with
            | Some t as x -> 
-               Hashtbl.remove ct b;
+              Hashtbl.remove ct a;
                Hashtbl.add ct a x; x
            | x -> x
       with Not_found -> assert false
@@ -201,81 +253,21 @@ module Make = functor (F:Format) -> struct
         | None ->
            match F.mtime_of_target_object b with
            | Some t as x -> 
-               Hashtbl.remove ct b;
+              Hashtbl.remove ct b;
                Hashtbl.add ct b x; x
            | x -> x
       with Not_found -> assert false
     in
-    match a, b with
-    | Some a, Some b -> a < b
+    let r = match a, b with
+    | Some a, Some b ->
+(*       
+       prerr_endline ("tt: a " ^ string_of_float a);
+       prerr_endline ("tt: b " ^ string_of_float b);
+*)       
+       a <= b
     | _ -> false
-  ;;
-
-  let is_built opts t tgt = 
-    younger_s_t opts t tgt
-  ;;
-
-  let assoc4 l k = List.find (fun (k1,_,_,_) -> k1 = k) l;;
-
-  let fst4 = function (x,_,_,_) -> x;;
-
-  let rec needs_build opts deps compiled (t,dependencies,root,tgt) =
-    say ("Checking if "^F.string_of_source_object t^ " needs to be built");
-    if List.mem t compiled then
-      (say "already compiled"; false)
-    else
-    if not (is_built opts t tgt) then
-      (say(F.string_of_source_object t^" is not built, thus needs to be built");
-      true)
-    else
-    try
-      let unsat =
-        List.find
-          (needs_build opts deps compiled) 
-          (List.map (assoc4 deps) dependencies)
-      in
-        say (F.string_of_source_object t^" depends on "^
-         F.string_of_source_object (fst4 unsat)^
-         " that needs to be built, thus needs to be built");
-        true
-    with Not_found ->
-      try 
-        let _,_,_,unsat = 
-          List.find 
-           (fun (_,_,_,tgt1) -> younger_t_t opts tgt tgt1) 
-           (List.map (assoc4 deps) dependencies)
-        in
-          say 
-           (F.string_of_source_object t^" depends on "^F.string_of_target_object
-           unsat^" and "^F.string_of_source_object t^".o is younger than "^
-           F.string_of_target_object unsat^", thus needs to be built");
-          true
-      with Not_found -> false
-  ;;
-
-  let is_buildable opts compiled deps (t,dependencies,root,tgt as what) =
-    say ("Checking if "^F.string_of_source_object t^" is buildable");
-    let b = needs_build opts deps compiled what in
-    if not b then
-      (say (F.string_of_source_object t^
-       " does not need to be built, thus it not buildable");
-      false)
-    else
-    try  
-      let unsat,_,_,_ =
-        List.find (needs_build opts deps compiled) 
-          (List.map (assoc4 deps) dependencies)
-      in
-        say (F.string_of_source_object t^" depends on "^
-          F.string_of_source_object unsat^
-          " that needs build, thus is not buildable");
-        false
-    with Not_found -> 
-      say 
-        ("None of "^F.string_of_source_object t^
-        " dependencies needs to be built, thus it is buildable");
-      true
-  ;;
+    in
+    prerr_endline ("L t_t: " ^ string_of_bool r); r
 
   let rec purge_unwanted_roots wanted deps =
     let roots, rest = 
@@ -291,15 +283,63 @@ module Make = functor (F:Format) -> struct
       purge_unwanted_roots wanted (newroots @ rest)
   ;;
 
-  let is_not_ro (opts,_,_) (f,_,r,_) =
+  let is_not_ro (opts,_,_,_,_) (f,_,r,_) =
     match r with
     | Some root -> not (F.is_readonly_buri_of opts f)
     | None -> assert false
   ;;
+(* FG: Old sorting algorithm ************************************************)
+(*
+  let rec get_status opts what =
+     let _, _, _, cc, cd = opts in
+     let t, dependencies, root, tgt = what in
+     try Done (Hashtbl.find cc t)
+(* say "already built" *)
+     with Not_found ->
+       let map st d = match st with
+          | Done false  -> st
+          | Ready false -> st
+          | _           ->
+             let whatd = Hashtbl.find cd d in
+             let _, _, _, tgtd = whatd in
+             begin match st, get_status opts whatd with
+                | _, Done false         -> Hashtbl.add cc t false; Done false
+                | Done true, Done true  -> 
+                   if modified_before_t_t opts tgt tgtd then Ready true else Done true  
+(* say (F.string_of_source_object t^" depends on "^F.string_of_target_object unsat^" and "^F.string_of_source_object t^".o is younger than "^ F.string_of_target_object unsat^", thus needs to be built") *)
+                 | Done true, Ready _    -> Ready false
+                | Ready true, Ready _   -> Ready false
+(* say (F.string_of_source_object t^" depends on "^ F.string_of_source_object (fst4 unsat)^ " that is not built, thus is not ready") *)
+                | Ready true, Done true -> Ready true
+                | _                     -> st
+             end
+       in
+        let st = if modified_before_s_t opts t tgt then Done true else Ready true in
+        match List.fold_left map st dependencies with
+          | Done true -> Hashtbl.add cc t true; Done true
+(* say(F.string_of_source_object t^" is built" *)
+          | st     -> st
+
+  let list_partition_filter_rev filter l =
+     let rec aux l1 l2 = function
+        | []       -> l1, l2
+       | hd :: tl ->
+          begin match filter hd with
+             | None       -> aux l1 l2 tl
+             | Some true  -> aux (hd :: l1) l2 tl
+             | Some false -> aux l1 (hd :: l2) tl
+          end
+     in
+     aux [] [] l
 
-  let rec make_aux root (lo,_,ct as opts) compiled failed deps = 
-    let todo = List.filter (is_buildable opts compiled deps) deps in
-    let todo = List.filter (fun (f,_,_,_)->not (List.mem f failed)) todo in
+  let rec make_aux root (lo,_,ct, cc, _ as opts) ok deps = 
+    time_stamp "filter get_status: begin";
+    let map what = match get_status opts what with
+       | Done _  -> None
+       | Ready b -> Some b
+    in
+    let todo, deps = list_partition_filter_rev map deps in
+    time_stamp "filter get_status: end";
     let todo =
       let local, remote =
         List.partition (fun (_,_,froot,_) -> froot = Some root) todo
@@ -311,36 +351,88 @@ module Make = functor (F:Format) -> struct
        skipped;
       remote @ local
     in
-    if todo <> [] then
-      let compiled, failed = 
-        List.fold_left 
-          (fun (c,f) (file,_,froot,tgt) ->
+    if todo <> [] then begin
+       let ok = List.fold_left  
+          (fun ok (file,_,froot,tgt) ->
             let rc = 
               match froot with
               | Some froot when froot = root -> 
-                  Hashtbl.remove ct tgt;
+                 Hashtbl.remove ct tgt;
                   Hashtbl.add ct tgt None;
-                  F.build lo file 
+                  time_stamp "building";
+                 let r = F.build lo file in
+                 time_stamp "done"; r
               | Some froot -> make froot [file]
               | None -> 
                   HLog.error ("No root for: "^F.string_of_source_object file);
                   false
             in
-            if rc then (file::c,f)
-            else (c,file::f))
-          (compiled,failed) todo
-      in
-        make_aux root opts compiled failed deps
+           Hashtbl.add cc file rc;
+           ok && rc 
+          )
+          ok (List.rev todo)
+       in
+      make_aux root opts ok (List.rev deps)
+    end
     else
-      compiled, failed
+      ok
+*)
+(* FG: new sorting algorithm ************************************************)
+
+  let rec make_aux root opts ok deps =
+    List.fold_left (make_one root opts) ok deps
+     
+  and make_one root opts ok what =
+    let lo, _, ct, cc, cd = opts in
+    let t, deps, froot, tgt = what in
+    let str = F.string_of_source_object t in
+    let map (okd, okt) d =
+       let (_, _, _, tgtd) as whatd = (Hashtbl.find cd d) in
+       let r = make_one root opts okd whatd in 
+       r, okt && modified_before_t_t opts tgtd tgt
+    in
+    prerr_endline ("L : processing " ^ str);
+    try 
+       let r = Hashtbl.find cc t in
+       prerr_endline ("L : " ^ string_of_bool r ^ " " ^ str);
+       ok && r
+(* say "already built" *)
+    with Not_found ->
+       let okd, okt = List.fold_left map (true, modified_before_s_t opts t tgt) deps in       
+       let res = 
+          if okd then 
+         if okt then true else
+          match froot with
+             | Some froot when froot = root -> 
+                if is_not_ro opts what then begin 
+                   Hashtbl.remove ct tgt;
+                   Hashtbl.add ct tgt None;
+                   time_stamp ("L : BUILDING " ^ str);
+                  let res = F.build lo t in
+                  time_stamp ("L : DONE     " ^ str); res
+               end else begin
+                  HLog.warn("Read only baseuri for: "^ str); false
+               end
+             | Some froot -> make froot [t]
+             | None -> 
+                HLog.error ("No root for: " ^ str); false
+          else false
+       in
+       prerr_endline ("L : " ^ string_of_bool res ^ " " ^ str);
+       Hashtbl.add cc t res; ok && res
 
-  and  make root targets = 
+(****************************************************************************)
+
+  and make root targets = 
+    time_stamp "L : ENTERING";
     HLog.debug ("Entering directory '"^root^"'");
     let old_root = Sys.getcwd () in
     Sys.chdir root;
     let deps = F.load_deps_file (root^"/depends") in
     let local_options = load_root_file (root^"/root") in
-    let caches,cachet = Hashtbl.create 73, Hashtbl.create 73 in
+    let caches,cachet,cachec,cached = 
+       Hashtbl.create 73, Hashtbl.create 73, Hashtbl.create 73, Hashtbl.create 73
+    in
     (* deps are enriched with these informations to sped up things later *)
     let deps = 
       List.map 
@@ -348,33 +440,36 @@ module Make = functor (F:Format) -> struct
           let r,tgt = F.root_and_target_of local_options file in
           Hashtbl.add caches file (F.mtime_of_source_object file);
           Hashtbl.add cachet tgt (F.mtime_of_target_object tgt); 
-          file, d, r, tgt)
+          Hashtbl.add cached file (file, d, r, tgt);
+          (file, d, r, tgt)
+       )
         deps
     in
-    let opts = local_options, caches, cachet in
-    let _compiled, failed =
+    let opts = local_options, caches, cachet, cachec, cached in
+    let ok =
       if targets = [] then 
-        make_aux root opts [] [] deps
+        make_aux root opts true deps
       else
-        make_aux root opts [] [] 
-          (purge_unwanted_roots (List.map F.dotdothack targets) deps)
+        make_aux root opts true 
+          (purge_unwanted_roots targets deps)
     in
     HLog.debug ("Leaving directory '"^root^"'");
     Sys.chdir old_root;
-    failed = []
+    time_stamp "L : LEAVING";
+    ok
   ;;
 
 end
   
-let write_deps_file root deps =
-  let oc = open_out (root ^ "/depends") in
-  List.iter 
-    (fun (t,d) -> output_string oc (t^" "^String.concat " " d^"\n")) 
-    deps;
-  close_out oc;
-  HLog.message ("Generated: " ^ root ^ "/depends")
-;;
-
+let write_deps_file where deps = match where with 
+   | Some root ->
+      let oc = open_out (root ^ "/depends") in
+      let map (t, d) = output_string oc (t^" "^String.concat " " d^"\n") in
+      List.iter map deps; close_out oc;
+      HLog.message ("Generated: " ^ root ^ "/depends")
+   | None -> 
+      print_endline (String.concat " " (List.flatten (List.map snd deps)))
+      
 (* FG ***********************************************************************)
 
 (* scheme uri part as defined in URI Generic Syntax (RFC 3986) *)