220 lines
7.0 KiB
OCaml
220 lines
7.0 KiB
OCaml
(***********************************************************************)
|
|
(* 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. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
|
|
(* 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 Resource.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
|