diff --git a/src/build_system.ml b/src/build_system.ml index a111c340ebb3..abae411d56b8 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -544,6 +544,19 @@ module Rule_fn = struct let loc () = Fdecl.get loc_decl () end +module Context_or_install = struct + type t = + | Install of string + | Context of string + + let to_sexp = function + | Install ctx -> Sexp.List [ Sexp.Atom "install"; Sexp.Atom ctx ] + | Context s -> + assert (not (s = "install")); + Sexp.Atom s +end + + type t = { (* File specification by targets *) files : Internal_rule.t Path.Table.t @@ -551,8 +564,8 @@ type t = ; file_tree : File_tree.t ; dirs : Dir_status.t Path.Table.t ; gen_rules : - (dir:Path.t -> string list -> extra_sub_directories_to_keep) - String.Map.t Fdecl.t + (Context_or_install.t -> + (dir:Path.t -> string list -> extra_sub_directories_to_keep) option) Fdecl.t ; mutable load_dir_stack : Path.t list ; (* Set of directories under _build that have at least one rule and all their ancestors. *) @@ -590,7 +603,6 @@ let string_of_source_paths set = let set_rule_generators generators = let t = t () in - assert (String.Map.keys generators = String.Map.keys t.contexts); Fdecl.set t.gen_rules generators let get_dir_status t ~dir = @@ -733,6 +745,14 @@ let no_rule_found = (Path.to_string_maybe_quoted fn) ctx (hint ctx (String.Map.keys t.contexts)) + | Install (ctx, _) -> + if String.Map.mem t.contexts ctx then + fail fn ~loc + else + die "Trying to build %s for install but build context %s doesn't exist.%s" + (Path.to_string_maybe_quoted fn) + ctx + (hint ctx (String.Map.keys t.contexts)) | Alias (ctx, fn') -> if String.Map.mem t.contexts ctx then fail fn ~loc @@ -920,95 +940,110 @@ and load_dir_and_get_targets t ~dir = reraise exn and load_dir_step2_exn t ~dir ~collector = - let context_name, sub_dir = Path.extract_build_context_exn dir in - let is_install = context_name = "install" in - (* This condition is [true] because of [get_dir_status] *) - assert (is_install || String.Map.mem t.contexts context_name); + let context_name, sub_dir = match Utils.analyse_target dir with + | Install (ctx, path) -> + Context_or_install.Install ctx, path + | Regular (ctx, path) -> + Context_or_install.Context ctx, path + | Alias _ | Other _ -> + Exn.code_error "[load_dir_step2_exn] was called on a strange path" + ["path", (Path.to_sexp dir)] + in (* Load all the rules *) let extra_subdirs_to_keep = - if is_install then - These String.Set.empty - else - let gen_rules = String.Map.find_exn (Fdecl.get t.gen_rules) context_name in - handle_add_rule_effects - (fun () -> - gen_rules ~dir (Path.Source.explode sub_dir)) + let gen_rules = + match (Fdecl.get t.gen_rules) context_name with + | None -> + Exn.code_error "[gen_rules] did not specify rules for the context" + ["context_name", (Context_or_install.to_sexp context_name)] + | Some rules -> + rules + in + handle_add_rule_effects (fun () -> gen_rules ~dir (Path.Source.explode sub_dir)) in let collector = Dir_status.Rules_collector.freeze collector in let rules = Dir_status.Rules_collector.rules collector in (* Compute alias rules *) - let alias_dir = Path.append_source (Path.relative alias_dir context_name) sub_dir in - let alias_rules, alias_stamp_files = - let open Build.O in - let aliases = - Dir_status.Rules_collector.aliases collector - in - let aliases = - if String.Map.mem aliases "default" then - aliases - else - match Path.extract_build_context_dir dir with - | None -> aliases - | Some (ctx_dir, src_dir) -> - match File_tree.find_dir t.file_tree src_dir with - | None -> aliases - | Some dir -> - String.Map.add aliases "default" - ({ deps = Path.Set.empty - ; dyn_deps = - (Alias0.dep_rec_internal ~name:"install" ~dir ~ctx_dir - >>^ fun (_ : bool) -> - Path.Set.empty) - ; actions = [] - } : Dir_status.Alias.immutable) - in - String.Map.foldi aliases ~init:([], Path.Set.empty) - ~f:(fun name { Dir_status.Alias.deps; dyn_deps; actions } (rules, alias_stamp_files) -> - let base_path = Path.relative alias_dir name in - let rules, action_stamp_files = - List.fold_left actions ~init:(rules, Path.Set.empty) - ~f:(fun (rules, action_stamp_files) - { Dir_status. stamp; action; locks ; context ; loc ; env } -> - let path = - Path.extend_basename base_path - ~suffix:("-" ^ Digest.to_string stamp) - in - let rule = - Pre_rule.make ~locks ~context:(Some context) ~env - ~info:(Rule.Info.of_loc_opt loc) - (Build.progn [ action; Build.create_file path ]) - in - (rule :: rules, Path.Set.add action_stamp_files path)) + let alias_dir, alias_rules = + match context_name with + | Context context_name -> + let alias_dir = Path.append_source (Path.relative alias_dir context_name) sub_dir in + let alias_rules, alias_stamp_files = + let open Build.O in + let aliases = + Dir_status.Rules_collector.aliases collector in - let deps = Path.Set.union deps action_stamp_files in - let path = Path.extend_basename base_path ~suffix:Alias0.suffix in - let targets = - Path.Set.add action_stamp_files path - |> Path.Set.union alias_stamp_files + let aliases = + if String.Map.mem aliases "default" then + aliases + else + match Path.extract_build_context_dir dir with + | None -> aliases + | Some (ctx_dir, src_dir) -> + match File_tree.find_dir t.file_tree src_dir with + | None -> aliases + | Some dir -> + String.Map.add aliases "default" + { deps = Path.Set.empty + ; dyn_deps = + (Alias0.dep_rec_internal ~name:"install" ~dir ~ctx_dir + >>^ fun (_ : bool) -> + Path.Set.empty) + ; actions = [] + } in - (Pre_rule.make - ~context:None - ~env:None - (Build.path_set deps >>> - dyn_deps >>> - Build.dyn_path_set (Build.arr Fn.id) - >>^ (fun dyn_deps -> - let deps = Path.Set.union deps dyn_deps in - Action.with_stdout_to path - (Action.digest_files (Path.Set.to_list deps))) - >>> - Build.action_dyn () ~targets:[path]) - :: rules, - targets)) + String.Map.foldi aliases ~init:([], Path.Set.empty) + ~f:(fun name { Dir_status.Alias. deps; dyn_deps; actions } (rules, alias_stamp_files) -> + let base_path = Path.relative alias_dir name in + let rules, action_stamp_files = + List.fold_left actions ~init:(rules, Path.Set.empty) + ~f:(fun (rules, action_stamp_files) + { Dir_status. stamp; action; locks ; context ; loc ; env } -> + let path = + Path.extend_basename base_path + ~suffix:("-" ^ Digest.to_string stamp) + in + let rule = + Pre_rule.make ~locks ~context:(Some context) ~env + ~info:(Rule.Info.of_loc_opt loc) + (Build.progn [ action; Build.create_file path ]) + in + (rule :: rules, Path.Set.add action_stamp_files path)) + in + let deps = Path.Set.union deps action_stamp_files in + let path = Path.extend_basename base_path ~suffix:Alias0.suffix in + let targets = + Path.Set.add action_stamp_files path + |> Path.Set.union alias_stamp_files + in + (Pre_rule.make + ~context:None + ~env:None + (Build.path_set deps >>> + dyn_deps >>> + Build.dyn_path_set (Build.arr Fn.id) + >>^ (fun dyn_deps -> + let deps = Path.Set.union deps dyn_deps in + Action.with_stdout_to path + (Action.digest_files (Path.Set.to_list deps))) + >>> + Build.action_dyn () ~targets:[path]) + :: rules, + targets)) + in + Path.Table.replace t.dirs ~key:alias_dir ~data:(Loaded alias_stamp_files); + Some alias_dir, alias_rules + | Install _ -> + None, [] in - Path.Table.replace t.dirs ~key:alias_dir ~data:(Loaded alias_stamp_files); let file_tree_dir = - if is_install then + match context_name with + | Install _ -> None - else + | Context _ -> File_tree.find_dir t.file_tree sub_dir in @@ -1042,11 +1077,14 @@ and load_dir_step2_exn t ~dir ~collector = in (* Take into account the source files *) let targets, to_copy, subdirs_to_keep = - if is_install then + match context_name with + | Install _ -> (user_rule_targets, None, String.Set.empty) - else + | Context context_name -> + (* This condition is [true] because of [get_dir_status] *) + assert (String.Map.mem t.contexts context_name); let files, subdirs = match file_tree_dir with | None -> (Path.Source.Set.empty, String.Set.empty) @@ -1145,7 +1183,8 @@ The following targets are not: remove_old_artifacts t ~dir ~subdirs_to_keep; List.iter alias_rules ~f:(compile_rule t); - remove_old_artifacts t ~dir:alias_dir ~subdirs_to_keep; + Option.iter alias_dir ~f:(fun alias_dir -> + remove_old_artifacts t ~dir:alias_dir ~subdirs_to_keep); targets diff --git a/src/build_system.mli b/src/build_system.mli index 94cd7b674446..e3bc12341470 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -24,11 +24,19 @@ type extra_sub_directories_to_keep = | All | These of String.Set.t +module Context_or_install : sig + type t = + | Install of string + | Context of string + + val to_sexp : t -> Sexp.t +end + (** Set the rule generators callback. There must be one callback per build context name. Each callback is used to generate the rules for a given directory - in the corresponding build context. It receive the directory for + in the corresponding build context. It receives the directory for which to generate the rules and the split part of the path after the build context. It must return an additional list of sub-directories to keep. This is in addition to the ones that are @@ -37,8 +45,9 @@ type extra_sub_directories_to_keep = It is expected that [f] only generate rules whose targets are descendant of [dir]. *) val set_rule_generators - : (dir:Path.t -> string list -> extra_sub_directories_to_keep) - String.Map.t -> unit + : (Context_or_install.t -> + (dir:Path.t -> string list -> extra_sub_directories_to_keep) option) + -> unit (** All other functions in this section must be called inside the rule generator callback. *) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index c896755b1f85..dc095ce5012f 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -344,8 +344,11 @@ let gen ~contexts in let+ contexts = Fiber.parallel_map contexts ~f:make_sctx in let map = String.Map.of_list_exn contexts in + let generators = (String.Map.map map ~f:(fun (module M : Gen) -> M.gen_rules)) in Build_system.set_rule_generators - (String.Map.map map ~f:(fun (module M : Gen) -> M.gen_rules)); + (function + | Install _ctx -> Some (fun ~dir:_ _path -> These String.Set.empty) + | Context ctx -> String.Map.find generators ctx); String.Map.iter map ~f:(fun (module M : Gen) -> M.init ()); String.Map.map map ~f:(fun (module M : Gen) -> M.sctx); diff --git a/src/process.ml b/src/process.ml index ba1597dd2919..12cd3177ae36 100644 --- a/src/process.ml +++ b/src/process.ml @@ -204,6 +204,9 @@ module Fancy = struct | Alias (ctx, name) -> split_paths (("alias " ^ Path.Source.to_string name) :: targets_acc) (add_ctx ctx ctxs_acc) rest + | Install (ctx, name) -> + split_paths (("install " ^ Path.Source.to_string name) :: targets_acc) + (add_ctx ctx ctxs_acc) rest in let targets = Path.Set.to_list targets in let target_names, contexts = split_paths [] [] targets in diff --git a/src/utils.ml b/src/utils.ml index 13aab66d8a0a..5ddcfd40e5d1 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -68,30 +68,36 @@ let signal_name = type target_kind = | Regular of string * Path.Source.t | Alias of string * Path.Source.t + | Install of string * Path.Source.t | Other of Path.t let analyse_target (fn as original_fn) = match Path.extract_build_dir_first_component fn with - | Some (".aliases", sub) -> begin - match Path.Relative.split_first_component sub with - | None -> Other fn - | Some (ctx, fn) -> - if Path.Relative.is_root fn then - Other original_fn - else - let basename = - match String.rsplit2 (Path.Relative.basename fn) ~on:'-' with - | None -> assert false - | Some (name, digest) -> - assert (String.length digest = 32); - name - in - Alias (ctx, - Path.Source.of_relative - (Path.Relative.relative (Path.Relative.parent_exn fn) basename)) - end - | Some ("install", _) -> Other fn - | Some (ctx, sub) -> Regular (ctx, Path.Source.of_relative sub) + | Some (".aliases", sub) -> + (match Path.Relative.split_first_component sub with + | None -> Other fn + | Some (ctx, fn) -> + if Path.Relative.is_root fn then + Other original_fn + else + let basename = + match String.rsplit2 (Path.Relative.basename fn) ~on:'-' with + | None -> assert false + | Some (name, digest) -> + assert (String.length digest = 32); + name + in + Alias (ctx, + Path.Source.relative + (Path.Source.of_relative (Path.Relative.parent_exn fn)) + basename)) + | Some ("install", sub) -> + (match Path.Relative.split_first_component sub with + | None -> Other fn + | Some (ctx, fn) -> + Install (ctx, Path.Source.of_relative fn)) + | Some (ctx, sub) -> + Regular (ctx, Path.Source.of_relative sub) | None -> Other fn @@ -103,6 +109,8 @@ let describe_target fn = match analyse_target fn with | Alias (ctx, p) -> sprintf "alias %s%s" (Path.Source.to_string_maybe_quoted p) (ctx_suffix ctx) + | Install (ctx, p) -> + sprintf "install %s%s" (Path.Source.to_string_maybe_quoted p) (ctx_suffix ctx) | Regular (ctx, fn) -> sprintf "%s%s" (Path.Source.to_string_maybe_quoted fn) (ctx_suffix ctx) | Other fn -> diff --git a/src/utils.mli b/src/utils.mli index 9c2a1b4501ce..987541eec5ec 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -40,6 +40,7 @@ val executable_object_directory type target_kind = | Regular of string (* build context *) * Path.Source.t | Alias of string (* build context *) * Path.Source.t + | Install of string (* build context *) * Path.Source.t | Other of Path.t (** Return the name of an alias from its stamp file *)