1 files changed, 219 insertions, 0 deletions
diff --git a/ocamlbuild/ocaml_dependencies.ml b/ocamlbuild/ocaml_dependencies.ml
new file mode 100644
index 000000000..4a10bf1dc
--- /dev/null
+++ b/ocamlbuild/ocaml_dependencies.ml
@@ -0,0 +1,219 @@
+(***********************************************************************)
+(*                             ocamlbuild                              *)
+(*                                                                     *)
+(*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+(* Original author: Nicolas Pouillard *)
+open My_std
+open Log
+open Tools
+open Ocaml_utils
+
+let mydprintf fmt = dprintf 10 fmt
+
+exception Circular_dependencies of string list * string
+
+module type INPUT = sig
+  val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a
+  val fold_libraries : (string -> string list -> 'a -> 'a) -> 'a -> 'a
+  val fold_packages : (string -> string list -> 'a -> 'a) -> 'a -> 'a
+end
+
+module Make (I : INPUT) = struct
+  open I
+
+  module SMap = Map.Make(String)
+
+  module Resources = Resource.Resources
+
+  module Utils = struct
+    let add = SMap.add
+
+    let empty = SMap.empty
+
+    let find_all_set x acc =
+      try SMap.find x acc with Not_found -> Resources.empty
+
+    let smap_add_set src dst acc =
+      SMap.add src (Resources.add dst (find_all_set src acc)) acc
+
+    let print_smap pp f smap =
+      Format.fprintf f "@[<hv0>{:@[<hv2>";
+      SMap.iter begin fun k v ->
+        Format.fprintf f "@ @[<2>%S =>@ %a@];" k pp v
+      end smap;
+      Format.fprintf f "@]@,:}@]"
+
+    let print_smap_list = print_smap pp_l
+
+    let print_smap_set = print_smap Resources.print
+
+    let print_lazy pp f l = pp f !*l
+
+    let find_all_list x acc =
+      try SMap.find x acc with Not_found -> []
+
+    let find_all_rec xs map =
+      let visited = Hashtbl.create 32 in
+      let rec self x acc =
+        try
+          Hashtbl.find visited x; acc
+        with Not_found ->
+          Hashtbl.replace visited x ();
+          let acc = Resources.add x acc in
+          try Resources.fold self (SMap.find x map) acc
+          with Not_found -> acc
+      in List.fold_right self xs Resources.empty
+
+    let mkindex fold filter =
+      fold begin fun name contents acc ->
+        if filter name then
+          List.fold_right begin fun elt acc ->
+            add elt (name :: (find_all_list elt acc)) acc
+          end contents acc
+        else
+          acc
+      end empty
+
+  end
+  open Utils
+
+  let caml_transitive_closure
+        ?(caml_obj_ext="cmo")
+        ?(caml_lib_ext="cma")
+        ?(pack_mode=false)
+        ?(used_libraries=[])
+        ?(hidden_packages=[]) fns =
+
+    let valid_link_exts =
+      if pack_mode then [caml_obj_ext; "cmi"]
+      else [caml_obj_ext; caml_lib_ext] in
+
+    mydprintf "caml_transitive_closure@ ~caml_obj_ext:%S@ ~pack_mode:%b@ ~used_libraries:%a@ %a"
+      caml_obj_ext pack_mode pp_l used_libraries pp_l fns;
+
+    let packages = fold_packages (fun name _ -> Resources.add name) Resources.empty in
+    mydprintf "packages:@ %a" Resources.print packages;
+
+    let caml_obj_ext_of_cmi x =
+      if Filename.check_suffix x ".cmi" then
+        Pathname.update_extensions caml_obj_ext x
+      else x in
+
+    let maybe_caml_obj_ext_of_cmi x =
+      if pack_mode then
+        if Filename.check_suffix x ".cmi" then
+          let caml_obj = Pathname.update_extensions caml_obj_ext x in
+          if Pathname.exists_in_build_dir caml_obj then
+            caml_obj
+          else
+            x
+        else
+          x
+      else
+        if Filename.check_suffix x ".cmi" then
+          Pathname.update_extensions caml_obj_ext x
+        else x in
+
+    let not_linkable x =
+      not (List.exists (Pathname.check_extension x) valid_link_exts) in
+
+    let dependency_map =
+      fold_dependencies begin fun x y acc ->
+        let x = maybe_caml_obj_ext_of_cmi x
+        and y = maybe_caml_obj_ext_of_cmi y in
+        if x = y || not_linkable x || not_linkable y then acc
+        else smap_add_set x y acc
+      end SMap.empty in
+    mydprintf "dependency_map:@ %a" print_smap_set dependency_map;
+
+    let used_files = find_all_rec fns dependency_map in
+    mydprintf "used_files:@ %a" Resources.print used_files;
+
+    let open_packages =
+      Resources.fold begin fun file acc ->
+        if Resources.mem file packages && not (List.mem file hidden_packages)
+        then file :: acc else acc
+      end used_files [] in
+    mydprintf "open_packages:@ %a" pp_l open_packages;
+
+    let index_filter ext list x =
+      Pathname.check_extension x ext && List.mem x list in
+
+    let lib_index =
+      lazy (mkindex fold_libraries (index_filter caml_lib_ext used_libraries)) in
+    mydprintf "lib_index:@ %a" (print_lazy print_smap_list) lib_index;
+
+    let package_index =
+      lazy (mkindex fold_packages (index_filter caml_obj_ext open_packages)) in
+
+    let rec resolve_packages x =
+      match find_all_list x !*package_index with
+      | [] -> x
+      | [x] -> resolve_packages x
+      | pkgs ->
+          failwith (sbprintf "the file %S is included in more than one active open package (%a)"
+                             x pp_l pkgs) in
+
+    let libs_of x = find_all_list x !*lib_index in
+
+    let lib_of x =
+      match libs_of x with
+      | [] -> None
+      | [lib] -> Some(lib)
+      | libs ->
+          failwith (sbprintf "the file %S is included in more than one active library (%a)"
+                             x pp_l libs) in
+
+    let convert_dependency src dst acc =
+      let src = resolve_packages src in
+      let dst = resolve_packages dst in
+      let add_if_diff x y = if x = y then acc else smap_add_set x y acc in
+      match (lib_of src, lib_of dst) with
+      | None, None -> add_if_diff src dst
+      | Some(liba), Some(libb) -> add_if_diff liba libb
+      | Some(lib), None -> add_if_diff lib dst
+      | None, Some(lib) -> add_if_diff src lib in
+
+    let dependencies = lazy begin
+      SMap.fold begin fun k ->
+        Resources.fold (convert_dependency k)
+      end dependency_map empty
+    end in
+
+    mydprintf "dependencies:@ %a" (print_lazy print_smap_set) dependencies;
+
+    let dependencies_of x =
+      try SMap.find x !*dependencies with Not_found -> Resources.empty in
+
+    let needed = ref [] in
+    let seen = ref [] in
+    let rec aux fn =
+      if sys_file_exists fn && not (List.mem fn !needed) then begin
+        if List.mem fn !seen then raise (Circular_dependencies (!seen, fn));
+        seen := fn :: !seen;
+        Resources.iter begin fun f ->
+          if sys_file_exists f then
+            if Filename.check_suffix f ".cmi" then
+              let f' = caml_obj_ext_of_cmi f in
+              if f' <> fn then
+                if sys_file_exists f' then aux f'
+                else if pack_mode then aux f else ()
+              else ()
+            else aux f
+        end (dependencies_of fn);
+        needed := fn :: !needed
+      end
+    in  
+    List.iter aux fns;
+    mydprintf "caml_transitive_closure:@ %a ->@ %a" pp_l fns pp_l !needed;
+    List.rev !needed
+
+end