l4/pkg/ocaml/contrib/ocamlbuild/ocaml_dependencies.ml

   1 (***********************************************************************)
   2 (*                             ocamlbuild                              *)
   3 (*                                                                     *)
   4 (*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
   5 (*                                                                     *)
   6 (*  Copyright 2007 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12
  13 (* Original author: Nicolas Pouillard *)
  14 open My_std
  15 open Log
  16 open Tools
  17 open Ocaml_utils
  18
  19 let mydprintf fmt = dprintf 10 fmt
  20
  21 exception Circular_dependencies of string list * string
  22
  23 module type INPUT = sig
  24   val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a
  25   val fold_libraries : (string -> string list -> 'a -> 'a) -> 'a -> 'a
  26   val fold_packages : (string -> string list -> 'a -> 'a) -> 'a -> 'a
  27 end
  28
  29 module Make (I : INPUT) = struct
  30   open I
  31
  32   module SMap = Map.Make(String)
  33
  34   module Resources = Resource.Resources
  35
  36   module Utils = struct
  37     let add = SMap.add
  38
  39     let empty = SMap.empty
  40
  41     let find_all_set x acc =
  42       try SMap.find x acc with Not_found -> Resources.empty
  43
  44     let smap_add_set src dst acc =
  45       SMap.add src (Resources.add dst (find_all_set src acc)) acc
  46
  47     let print_smap pp f smap =
  48       Format.fprintf f "@[<hv0>{:@[<hv2>";
  49       SMap.iter begin fun k v ->
  50         Format.fprintf f "@ @[<2>%S =>@ %a@];" k pp v
  51       end smap;
  52       Format.fprintf f "@]@,:}@]"
  53
  54     let print_smap_list = print_smap pp_l
  55
  56     let print_smap_set = print_smap Resources.print
  57
  58     let print_lazy pp f l = pp f !*l
  59
  60     let find_all_list x acc =
  61       try SMap.find x acc with Not_found -> []
  62
  63     let find_all_rec xs map =
  64       let visited = Hashtbl.create 32 in
  65       let rec self x acc =
  66         try
  67           Hashtbl.find visited x; acc
  68         with Not_found ->
  69           Hashtbl.replace visited x ();
  70           let acc = Resources.add x acc in
  71           try Resources.fold self (SMap.find x map) acc
  72           with Not_found -> acc
  73       in List.fold_right self xs Resources.empty
  74
  75     let mkindex fold filter =
  76       fold begin fun name contents acc ->
  77         if filter name then
  78           List.fold_right begin fun elt acc ->
  79             add elt (name :: (find_all_list elt acc)) acc
  80           end contents acc
  81         else
  82           acc
  83       end empty
  84
  85   end
  86   open Utils
  87
  88   let caml_transitive_closure
  89         ?(caml_obj_ext="cmo")
  90         ?(caml_lib_ext="cma")
  91         ?(pack_mode=false)
  92         ?(used_libraries=[])
  93         ?(hidden_packages=[]) fns =
  94
  95     let valid_link_exts =
  96       if pack_mode then [caml_obj_ext; "cmi"]
  97       else [caml_obj_ext; caml_lib_ext] in
  98
  99     mydprintf "caml_transitive_closure@ ~caml_obj_ext:%S@ ~pack_mode:%b@ ~used_libraries:%a@ %a"
 100       caml_obj_ext pack_mode pp_l used_libraries pp_l fns;
 101
 102     let packages = fold_packages (fun name _ -> Resources.add name) Resources.empty in
 103     mydprintf "packages:@ %a" Resources.print packages;
 104
 105     let caml_obj_ext_of_cmi x =
 106       if Filename.check_suffix x ".cmi" then
 107         Pathname.update_extensions caml_obj_ext x
 108       else x in
 109
 110     let maybe_caml_obj_ext_of_cmi x =
 111       if pack_mode then
 112         if Filename.check_suffix x ".cmi" then
 113           let caml_obj = Pathname.update_extensions caml_obj_ext x in
 114           if Resource.exists_in_build_dir caml_obj then
 115             caml_obj
 116           else
 117             x
 118         else
 119           x
 120       else
 121         if Filename.check_suffix x ".cmi" then
 122           Pathname.update_extensions caml_obj_ext x
 123         else x in
 124
 125     let not_linkable x =
 126       not (List.exists (Pathname.check_extension x) valid_link_exts) in
 127
 128     let dependency_map =
 129       fold_dependencies begin fun x y acc ->
 130         let x = maybe_caml_obj_ext_of_cmi x
 131         and y = maybe_caml_obj_ext_of_cmi y in
 132         if x = y || not_linkable x || not_linkable y then acc
 133         else smap_add_set x y acc
 134       end SMap.empty in
 135     mydprintf "dependency_map:@ %a" print_smap_set dependency_map;
 136
 137     let used_files = find_all_rec fns dependency_map in
 138     mydprintf "used_files:@ %a" Resources.print used_files;
 139
 140     let open_packages =
 141       Resources.fold begin fun file acc ->
 142         if Resources.mem file packages && not (List.mem file hidden_packages)
 143         then file :: acc else acc
 144       end used_files [] in
 145     mydprintf "open_packages:@ %a" pp_l open_packages;
 146
 147     let index_filter ext list x =
 148       Pathname.check_extension x ext && List.mem x list in
 149
 150     let lib_index =
 151       lazy (mkindex fold_libraries (index_filter caml_lib_ext used_libraries)) in
 152     mydprintf "lib_index:@ %a" (print_lazy print_smap_list) lib_index;
 153
 154     let package_index =
 155       lazy (mkindex fold_packages (index_filter caml_obj_ext open_packages)) in
 156
 157     let rec resolve_packages x =
 158       match find_all_list x !*package_index with
 159       | [] -> x
 160       | [x] -> resolve_packages x
 161       | pkgs ->
 162           failwith (sbprintf "the file %S is included in more than one active open package (%a)"
 163                              x pp_l pkgs) in
 164
 165     let libs_of x = find_all_list x !*lib_index in
 166
 167     let lib_of x =
 168       match libs_of x with
 169       | [] -> None
 170       | [lib] -> Some(lib)
 171       | libs ->
 172           failwith (sbprintf "the file %S is included in more than one active library (%a)"
 173                              x pp_l libs) in
 174
 175     let convert_dependency src dst acc =
 176       let src = resolve_packages src in
 177       let dst = resolve_packages dst in
 178       let add_if_diff x y = if x = y then acc else smap_add_set x y acc in
 179       match (lib_of src, lib_of dst) with
 180       | None, None -> add_if_diff src dst
 181       | Some(liba), Some(libb) -> add_if_diff liba libb
 182       | Some(lib), None -> add_if_diff lib dst
 183       | None, Some(lib) -> add_if_diff src lib in
 184
 185     let dependencies = lazy begin
 186       SMap.fold begin fun k ->
 187         Resources.fold (convert_dependency k)
 188       end dependency_map empty
 189     end in
 190
 191     mydprintf "dependencies:@ %a" (print_lazy print_smap_set) dependencies;
 192
 193     let dependencies_of x =
 194       try SMap.find x !*dependencies with Not_found -> Resources.empty in
 195
 196     let needed = ref [] in
 197     let seen = ref [] in
 198     let rec aux fn =
 199       if sys_file_exists fn && not (List.mem fn !needed) then begin
 200         if List.mem fn !seen then raise (Circular_dependencies (!seen, fn));
 201         seen := fn :: !seen;
 202         Resources.iter begin fun f ->
 203           if sys_file_exists f then
 204             if Filename.check_suffix f ".cmi" then
 205               let f' = caml_obj_ext_of_cmi f in
 206               if f' <> fn then
 207                 if sys_file_exists f' then aux f'
 208                 else if pack_mode then aux f else ()
 209               else ()
 210             else aux f
 211         end (dependencies_of fn);
 212         needed := fn :: !needed
 213       end
 214     in
 215     List.iter aux fns;
 216     mydprintf "caml_transitive_closure:@ %a ->@ %a" pp_l fns pp_l !needed;
 217     List.rev !needed
 218
 219 end