From d219020b2f3fa9a9a502eb3de3b5d30ae0a061a1 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 18 May 2017 19:05:01 +0100 Subject: [PATCH] added jbuilder extract-makefile --- Makefile | 3 + bin/main.ml | 60 +++++++++++++----- bin/main.mli | 1 + doc/jbuild | 1 + src/build_system.ml | 143 +++++++++++++++++++++++++++++++++++++------ src/build_system.mli | 19 ++++++ 6 files changed, 195 insertions(+), 32 deletions(-) create mode 100644 bin/main.mli diff --git a/Makefile b/Makefile index 98d17725..f20d75f7 100644 --- a/Makefile +++ b/Makefile @@ -24,4 +24,7 @@ all-supported-ocaml-versions: clean: rm -rf _build +extract-makefile: + $(BIN) extract-makefile -o Makefile.extracted @install + .PHONY: default install uninstall reinstall clean test diff --git a/bin/main.ml b/bin/main.ml index 9ede1a02..984f35ba 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -50,20 +50,6 @@ end let do_build (setup : Main.setup) targets = Build_system.do_build_exn setup.build_system targets -type ('a, 'b) walk_result = - | Cont of 'a - | Stop of 'b - -let rec walk_parents dir ~init ~f = - match f init dir with - | Stop x -> Stop x - | Cont x -> - let parent = Filename.dirname dir in - if parent = dir then - Cont x - else - walk_parents parent ~init:x ~f - let find_root () = let cwd = Sys.getcwd () in let rec loop counter ~candidates ~to_cwd dir = @@ -527,6 +513,51 @@ let external_lib_deps = & Arg.info [] ~docv:"TARGET")) , Term.info "external-lib-deps" ~doc ~man) +let extract_makefile = + let doc = "Extract a makefile that can build the given targets." in + let man = + [ `S "DESCRIPTION" + ; `P {|Extract a makefile that can build the given targets.|} + ; `Blocks help_secs + ] + in + let go common out targets = + set_common common; + let log = Log.create () in + Future.Scheduler.go ~log + (Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false + >>= fun setup -> + let targets = + match targets with + | [] -> Build_system.all_targets setup.build_system + | _ -> resolve_targets ~log common setup targets + in + Build_system.build_rules setup.build_system targets >>= fun rules -> + Io.with_file_out out ~f:(fun oc -> + let ppf = Format.formatter_of_out_channel oc in + List.iter rules ~f:(fun (rule : Build_system.Rule.t) -> + Format.fprintf ppf "%s:%s\n\t%s\n\n" + (Path.Set.elements rule.targets + |> List.map ~f:Path.to_string + |> String.concat ~sep:" ") + (Path.Set.elements rule.deps + |> List.map ~f:(fun p -> " " ^ Path.to_string p) + |> String.concat ~sep:"") + (Action.sexp_of_t rule.action |> Sexp.to_string)); + Format.pp_print_flush ppf ()); + Future.return ()) + in + ( Term.(const go + $ common + $ Arg.(required + & opt (some string) None + & info ["o"] ~docv:"FILE" + ~doc:"Output file.") + $ Arg.(value + & pos_all string [] + & Arg.info [] ~docv:"TARGET")) + , Term.info "extract-makefile" ~doc ~man) + let opam_installer () = match Bin.which "opam-installer" with | None -> @@ -696,6 +727,7 @@ let all = ; uninstall ; exec ; subst + ; extract_makefile ] let default = diff --git a/bin/main.mli b/bin/main.mli new file mode 100644 index 00000000..e790aeb7 --- /dev/null +++ b/bin/main.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/doc/jbuild b/doc/jbuild index e4cf1f24..210d1c62 100644 --- a/doc/jbuild +++ b/doc/jbuild @@ -11,6 +11,7 @@ let commands = ; "uninstall" ; "exec" ; "subst" + ; "extract-makefile" ] let jbuild = diff --git a/src/build_system.ml b/src/build_system.ml index b20f6a7c..7b417bf0 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -18,14 +18,34 @@ module Exec_status = struct | Running of Running.t end -module Rule = struct +module Internal_rule = struct + module Id : sig + type t + val to_int : t -> int + val compare : t -> t -> int + val gen : unit -> t + end = struct + type t = int + let to_int x = x + let compare (x : int) y = compare x y + + let counter = ref 0 + let gen () = + let n = !counter in + counter := n + 1; + n + end + type t = - { rule_deps : Pset.t + { id : Id.t + ; rule_deps : Pset.t ; static_deps : Pset.t ; targets : Pset.t ; build : (unit, Action.t) Build.t ; mutable exec : Exec_status.t } + + let compare a b = Id.compare a.id b.id end module File_kind = struct @@ -44,7 +64,7 @@ end module File_spec = struct type 'a t = - { rule : Rule.t (* Rule which produces it *) + { rule : Internal_rule.t (* Rule which produces it *) ; mutable kind : 'a File_kind.t ; mutable data : 'a option } @@ -478,8 +498,9 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = ) ) in let rule = - { Rule. - static_deps + { Internal_rule. + id = Internal_rule.Id.gen () + ; static_deps ; rule_deps ; targets ; build @@ -628,34 +649,43 @@ let do_build t targets = with Build_error.E e -> Error e +module Ir_set = Set.Make(Internal_rule) + let rules_for_files t paths = List.filter_map paths ~f:(fun path -> match Hashtbl.find t.files path with | None -> None - | Some (File_spec.T { rule; _ }) -> Some (path, rule)) + | Some (File_spec.T { rule; _ }) -> Some rule) + |> Ir_set.of_list + |> Ir_set.elements -module File_closure = - Top_closure.Make(Path) +module Ir_closure = + Top_closure.Make(Internal_rule.Id) (struct type graph = t - type t = Path.t * Rule.t - let key (path, _) = path - let deps (_, rule) bs = - rules_for_files bs (Pset.elements (Pset.union rule.Rule.static_deps rule.Rule.rule_deps)) + type t = Internal_rule.t + let key (t : t) = t.id + let deps (t : t) bs = + rules_for_files bs + (Pset.elements + (Pset.union + t.static_deps + t.rule_deps)) end) let rules_for_targets t targets = - match File_closure.top_closure t (rules_for_files t targets) with + match Ir_closure.top_closure t (rules_for_files t targets) with | Ok l -> l | Error cycle -> die "dependency cycle detected:\n %s" - (List.map cycle ~f:(fun (path, _) -> Path.to_string path) + (List.map cycle ~f:(fun rule -> + Path.to_string (Pset.choose rule.Internal_rule.targets)) |> String.concat ~sep:"\n-> ") let all_lib_deps t targets = List.fold_left (rules_for_targets t targets) ~init:Pmap.empty - ~f:(fun acc (_, rule) -> - let lib_deps = Build_interpret.lib_deps rule.Rule.build in + ~f:(fun acc rule -> + let lib_deps = Build_interpret.lib_deps rule.Internal_rule.build in Pmap.merge acc lib_deps ~f:(fun _ a b -> match a, b with | None, None -> None @@ -664,8 +694,8 @@ let all_lib_deps t targets = | Some a, Some b -> Some (Build.merge_lib_deps a b))) let all_lib_deps_by_context t targets = - List.fold_left (rules_for_targets t targets) ~init:[] ~f:(fun acc (_, rule) -> - let lib_deps = Build_interpret.lib_deps rule.Rule.build in + List.fold_left (rules_for_targets t targets) ~init:[] ~f:(fun acc rule -> + let lib_deps = Build_interpret.lib_deps rule.Internal_rule.build in Path.Map.fold lib_deps ~init:acc ~f:(fun ~key:path ~data:lib_deps acc -> match Path.extract_build_context path with | None -> acc @@ -674,3 +704,80 @@ let all_lib_deps_by_context t targets = |> String_map.map ~f:(function | [] -> String_map.empty | x :: l -> List.fold_left l ~init:x ~f:Build.merge_lib_deps) + +module Rule = struct + module Id = Internal_rule.Id + + type t = + { id : Id.t + ; deps : Path.Set.t + ; targets : Path.Set.t + ; action : Action.t + } + + let compare a b = Id.compare a.id b.id +end + +module Rule_set = Set.Make(Rule) +module Id_set = Set.Make(Rule.Id) + +let rules_for_files rules paths = + List.fold_left paths ~init:Rule_set.empty ~f:(fun acc path -> + match Pmap.find path rules with + | None -> acc + | Some rule -> Rule_set.add rule acc) + |> Rule_set.elements + +module Rule_closure = + Top_closure.Make(Rule.Id) + (struct + type graph = Rule.t Pmap.t + type t = Rule.t + let key (t : t) = t.id + let deps (t : t) (graph : graph) = + rules_for_files graph (Pset.elements t.deps) + end) + +let build_rules t targets = + let rules_seen = ref Id_set.empty in + let rules = ref [] in + let rec loop fn = + match Hashtbl.find t.files fn with + | None -> return () + | Some (File_spec.T { rule = ir; _ }) -> + if Id_set.mem ir.id !rules_seen then + return () + else begin + rules_seen := Id_set.add ir.id !rules_seen; + let rule = + wait_for_deps t ir.rule_deps ~targeting:fn + >>= fun () -> + let action, dyn_deps = Build_exec.exec t ir.build () in + return + { Rule. + id = ir.id + ; deps = Pset.union ir.static_deps dyn_deps + ; targets = ir.targets + ; action = action + } + in + rules := rule :: !rules; + rule >>= fun rule -> + Future.all_unit (List.map (Pset.elements rule.deps) ~f:loop) + end + in + Future.all_unit (List.map targets ~f:loop) + >>= fun () -> + Future.all !rules + >>| fun rules -> + let rules = + List.fold_left rules ~init:Pmap.empty ~f:(fun acc (r : Rule.t) -> + Pset.fold r.targets ~init:acc ~f:(fun fn acc -> + Pmap.add acc ~key:fn ~data:r)) + in + match Rule_closure.top_closure rules (rules_for_files rules targets) with + | Ok l -> l + | Error cycle -> + die "dependency cycle detected:\n %s" + (List.map cycle ~f:(fun rule -> Path.to_string (Pset.choose rule.Rule.targets)) + |> String.concat ~sep:"\n-> ") diff --git a/src/build_system.mli b/src/build_system.mli index 84453a9a..02a1feb8 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -36,3 +36,22 @@ val all_lib_deps_by_context : t -> Path.t list -> Build.lib_deps String_map.t (** List of all buildable targets *) val all_targets : t -> Path.t list + +(** A fully built rule *) +module Rule : sig + module Id : sig + type t + val to_int : t -> int + val compare : t -> t -> int + end + + type t = + { id : Id.t + ; deps : Path.Set.t + ; targets : Path.Set.t + ; action : Action.t + } +end + +(** Build and the rules needed to build these targets *) +val build_rules : t -> Path.t list -> Rule.t list Future.t