Skip to content

Commit

Permalink
Factor out targets into a separate module
Browse files Browse the repository at this point in the history
Signed-off-by: Andrey Mokhov <[email protected]>
  • Loading branch information
snowleopard committed Oct 23, 2021
1 parent a0e9a3a commit 14b6286
Show file tree
Hide file tree
Showing 43 changed files with 281 additions and 156 deletions.
1 change: 1 addition & 0 deletions bin/import.ml
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@ module Colors = Dune_rules.Colors
module Dune_project = Dune_engine.Dune_project
module Workspace = Dune_rules.Workspace
module Cached_digest = Dune_engine.Cached_digest
module Targets = Dune_engine.Targets
module Profile = Dune_rules.Profile
module Log = Dune_util.Log
module Dune_rpc = Dune_rpc_private
Expand Down
4 changes: 2 additions & 2 deletions bin/print_rules.ml
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,7 @@ let print_rule_makefile ppf (rule : Dune_engine.Reflection.Rule.t) =
"@[<hov 2>@{<makefile-stuff>%a:%t@}@]@,@<0>\t@{<makefile-action>%a@}@,@,"
(Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf p ->
Format.pp_print_string ppf (Path.to_string p)))
(List.map ~f:Path.build (Path.Build.Set.to_list rule.targets))
(Targets.to_list_map rule.targets ~file:Path.build)
(fun ppf ->
Path.Set.iter rule.expanded_deps ~f:(fun dep ->
Format.fprintf ppf "@ %s" (Path.to_string dep)))
Expand All @@ -55,7 +55,7 @@ let print_rule_sexp ppf (rule : Dune_engine.Reflection.Rule.t) =
[ [ ("deps", Dep.Set.encode rule.deps)
; ( "targets"
, paths
(Path.Build.Set.to_list rule.targets
(Targets.to_list_map rule.targets ~file:Fun.id
|> Path.set_of_build_paths_list) )
]
; (match rule.context with
Expand Down
61 changes: 32 additions & 29 deletions src/dune_engine/action_builder.ml
Original file line number Diff line number Diff line change
Expand Up @@ -131,44 +131,42 @@ let source_tree ~dir =
}

(* CR-someday amokhov: The set of targets is accumulated using information from
multiple sources by calling [Path.Build.Set.union] and hence occasionally
duplicate declarations of the very same target go unnoticed. I think such
redeclarations are not erroneous but are merely redundant; it seems that it
would be better to rule them out completely.
Another improvement is to cache [Path.Build.Set.to_list targets] which is
currently performed multiple times on the very same
[Action_builder.With_targets.t]. *)
multiple sources by calling [Targets.combine], which performs set union and
hence duplicate declarations of the very same target can go unnoticed. I
think such redeclarations are not erroneous but are merely redundant; perhaps
we should detect and disallow them. *)
module With_targets = struct
type nonrec 'a t =
{ build : 'a t
; targets : Path.Build.Set.t
; targets : Targets.t
}

let map_build t ~f = { t with build = f t.build }

let return x = { build = return x; targets = Path.Build.Set.empty }
let return x = { build = return x; targets = Targets.empty }

let add t ~targets =
let add t ~file_targets =
{ build = t.build
; targets = Path.Build.Set.union t.targets (Path.Build.Set.of_list targets)
; targets =
Targets.combine t.targets
(Targets.Files.create (Path.Build.Set.of_list file_targets))
}

let map { build; targets } ~f = { build = map build ~f; targets }

let map2 x y ~f =
{ build = map2 x.build y.build ~f
; targets = Path.Build.Set.union x.targets y.targets
; targets = Targets.combine x.targets y.targets
}

let both x y =
{ build = both x.build y.build
; targets = Path.Build.Set.union x.targets y.targets
; targets = Targets.combine x.targets y.targets
}

let seq x y =
{ build = x.build >>> y.build
; targets = Path.Build.Set.union x.targets y.targets
; targets = Targets.combine x.targets y.targets
}

module O = struct
Expand All @@ -186,48 +184,53 @@ module With_targets = struct
| [] -> return []
| xs ->
let build, targets =
List.fold_left xs ~init:([], Path.Build.Set.empty)
~f:(fun (xs, set) x ->
(x.build :: xs, Path.Build.Set.union set x.targets))
List.fold_left xs ~init:([], Targets.empty)
~f:(fun (builds, targets) x ->
(x.build :: builds, Targets.combine x.targets targets))
in
{ build = all (List.rev build); targets }

let write_file_dyn ?(perm = Action.File_perm.Normal) fn s =
add ~targets:[ fn ]
add ~file_targets:[ fn ]
(let+ s = s in
Action.Write_file (fn, perm, s))

let memoize name t = { build = memoize name t.build; targets = t.targets }
end

let with_targets build ~targets : _ With_targets.t =
{ build; targets = Path.Build.Set.of_list targets }
let with_targets build ~targets : _ With_targets.t = { build; targets }

let with_targets_set build ~targets : _ With_targets.t = { build; targets }
let with_file_targets build ~file_targets : _ With_targets.t =
{ build
; targets = Targets.Files.create (Path.Build.Set.of_list file_targets)
}

let with_no_targets build : _ With_targets.t =
{ build; targets = Path.Build.Set.empty }
{ build; targets = Targets.empty }

let write_file ?(perm = Action.File_perm.Normal) fn s =
with_targets ~targets:[ fn ] (return (Action.Write_file (fn, perm, s)))
with_file_targets ~file_targets:[ fn ]
(return (Action.Write_file (fn, perm, s)))

let write_file_dyn ?(perm = Action.File_perm.Normal) fn s =
with_targets ~targets:[ fn ]
with_file_targets ~file_targets:[ fn ]
(let+ s = s in
Action.Write_file (fn, perm, s))

let copy ~src ~dst =
with_targets ~targets:[ dst ] (path src >>> return (Action.Copy (src, dst)))
with_file_targets ~file_targets:[ dst ]
(path src >>> return (Action.Copy (src, dst)))

let copy_and_add_line_directive ~src ~dst =
with_targets ~targets:[ dst ]
with_file_targets ~file_targets:[ dst ]
(path src >>> return (Action.Copy_and_add_line_directive (src, dst)))

let symlink ~src ~dst =
with_targets ~targets:[ dst ] (path src >>> return (Action.Symlink (src, dst)))
with_file_targets ~file_targets:[ dst ]
(path src >>> return (Action.Symlink (src, dst)))

let create_file ?(perm = Action.File_perm.Normal) fn =
with_targets ~targets:[ fn ]
with_file_targets ~file_targets:[ fn ]
(return (Action.Redirect_out (Stdout, fn, perm, Action.empty)))

let progn ts =
Expand Down
15 changes: 8 additions & 7 deletions src/dune_engine/action_builder.mli
Original file line number Diff line number Diff line change
Expand Up @@ -10,14 +10,14 @@ module With_targets : sig

type nonrec 'a t =
{ build : 'a t
; targets : Path.Build.Set.t
; targets : Targets.t
}

val map_build : 'a t -> f:('a build -> 'b build) -> 'b t

val return : 'a -> 'a t

val add : 'a t -> targets:Path.Build.t list -> 'a t
val add : 'a t -> file_targets:Path.Build.t list -> 'a t

val map : 'a t -> f:('a -> 'b) -> 'b t

Expand All @@ -42,12 +42,13 @@ module With_targets : sig
end
with type 'a build := 'a t

(** Add a set of targets to an action builder, turning a target-less
[Action_builder.t] into [Action_builder.With_targets.t]. *)
val with_targets : 'a t -> targets:Path.Build.t list -> 'a With_targets.t
(** Add targets to an action builder, turning a target-less [Action_builder.t]
into [Action_builder.With_targets.t]. *)
val with_targets : 'a t -> targets:Targets.t -> 'a With_targets.t

(** [with_targets_set] is like [with_targets] but [targets] is a set *)
val with_targets_set : 'a t -> targets:Path.Build.Set.t -> 'a With_targets.t
(** Like [with_targets] but specifies a list of file targets. *)
val with_file_targets :
'a t -> file_targets:Path.Build.t list -> 'a With_targets.t

(** Create a value of [With_targets.t] with the empty set of targets. *)
val with_no_targets : 'a t -> 'a With_targets.t
Expand Down
5 changes: 2 additions & 3 deletions src/dune_engine/action_exec.ml
Original file line number Diff line number Diff line change
Expand Up @@ -71,7 +71,7 @@ type done_or_more_deps =
| Need_more_deps of (DAP.Dependency.Set.t * Dynamic_dep.Set.t)

type exec_context =
{ targets : Path.Build.Set.t
{ targets : Targets.t
; context : Build_context.t option
; purpose : Process.purpose
; rule_loc : Loc.t
Expand Down Expand Up @@ -127,8 +127,7 @@ let exec_run_dynamic_client ~ectx ~eenv prog args =
let to_relative path =
path |> Stdune.Path.build |> Stdune.Path.reach ~from:eenv.working_dir
in
Stdune.Path.Build.Set.to_list ectx.targets
|> String.Set.of_list_map ~f:to_relative
Targets.to_list_map ectx.targets ~file:to_relative |> String.Set.of_list
in
DAP.Run_arguments.
{ prepared_dependencies = eenv.prepared_dependencies; targets }
Expand Down
2 changes: 1 addition & 1 deletion src/dune_engine/action_exec.mli
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,7 @@ end
(** [root] should be the root of the current build context, or the root of the
sandbox if the action is sandboxed. *)
val exec :
targets:Path.Build.Set.t
targets:Targets.t
-> root:Path.t
-> context:Build_context.t option
-> env:Env.t
Expand Down
51 changes: 28 additions & 23 deletions src/dune_engine/build_system.ml
Original file line number Diff line number Diff line change
Expand Up @@ -520,7 +520,8 @@ let () =
Path.Build.Set.iter fns ~f:(fun p -> Path.unlink_no_err (Path.build p)))

let compute_target_digests targets =
Option.List.traverse (Path.Build.Set.to_list targets) ~f:(fun target ->
Option.List.traverse (Targets.to_list_map targets ~file:Fun.id)
~f:(fun target ->
Cached_digest.build_file target
|> Cached_digest.Digest_result.to_option
|> Option.map ~f:(fun digest -> (target, digest)))
Expand All @@ -535,15 +536,15 @@ let compute_target_digests_or_raise_error exec_params ~loc targets =
(* FIXME: searching the dune version for each single target seems way
suboptimal. This information could probably be stored in rules
directly. *)
if Path.Build.Set.is_empty targets then
if Targets.is_empty targets then
false
else
Execution_parameters.should_remove_write_permissions_on_generated_files
exec_params
in
let good, missing, errors =
Path.Build.Set.fold targets ~init:([], [], [])
~f:(fun target (good, missing, errors) ->
Targets.fold targets ~init:([], [], [])
~file:(fun target (good, missing, errors) ->
let expected_syscall_path = Path.to_string (Path.build target) in
match Cached_digest.refresh ~remove_write_permissions target with
| Ok digest -> ((target, digest) :: good, missing, errors)
Expand Down Expand Up @@ -773,13 +774,13 @@ end = struct
we try to sandbox this. *)
~sandbox:Sandbox_config.no_sandboxing ~context:None
~info:(Source_file_copy path)
~targets:(Path.Build.Set.singleton ctx_path)
~targets:(Targets.File.create ctx_path)
build)

let compile_rules ~dir ~source_dirs rules =
List.concat_map rules ~f:(fun rule ->
assert (Path.Build.( = ) dir rule.Rule.dir);
Path.Build.Set.to_list_map rule.targets ~f:(fun target ->
Targets.to_list_map rule.targets ~file:(fun target ->
if String.Set.mem source_dirs (Path.Build.basename target) then
report_rule_src_dir_conflict dir target rule
else
Expand Down Expand Up @@ -851,8 +852,9 @@ end = struct
(* All targets are in [dir] and we know it correspond to a directory
of a build context since there are source files to copy, so this
call can't fail. *)
Path.Build.Set.to_list rule.targets
|> Path.Source.Set.of_list_map ~f:Path.Build.drop_build_context_exn
Targets.to_list_map rule.targets
~file:Path.Build.drop_build_context_exn
|> Path.Source.Set.of_list
in
if Path.Source.Set.is_subset source_files_for_targets ~of_:to_copy
then
Expand Down Expand Up @@ -1020,10 +1022,10 @@ end = struct
match mode with
| Promote { only = None; _ }
| Ignore_source_files ->
Path.Build.Set.union targets acc_ignored
Path.Build.Set.union (Targets.files targets) acc_ignored
| Promote { only = Some pred; _ } ->
let to_ignore =
Path.Build.Set.filter targets ~f:(fun target ->
Path.Build.Set.filter (Targets.files targets) ~f:(fun target ->
Predicate_lang.Glob.exec pred
(Path.reach (Path.build target) ~from:(Path.build dir))
~standard:Predicate_lang.any)
Expand Down Expand Up @@ -1361,7 +1363,7 @@ end = struct
let trace =
( rule_digest_version (* Update when changing the rule digest scheme. *)
, Dep.Facts.digest deps ~sandbox_mode ~env
, Path.Build.Set.to_list_map rule.targets ~f:Path.Build.to_string
, Targets.to_list_map rule.targets ~file:Path.Build.to_string
, Option.map rule.context ~f:(fun c -> Context_name.to_string c.name)
, Action.for_shell action
, can_go_in_shared_cache
Expand Down Expand Up @@ -1430,7 +1432,8 @@ end = struct
let { Action.Full.action; env; locks; can_go_in_shared_cache = _ } =
action
in
pending_targets := Path.Build.Set.union targets !pending_targets;
let file_targets = Targets.files targets in
pending_targets := Path.Build.Set.union file_targets !pending_targets;
let chdirs = Action.chdirs action in
let sandbox =
Option.map sandbox_mode ~f:(fun mode ->
Expand Down Expand Up @@ -1473,7 +1476,7 @@ end = struct
in
Option.iter sandbox ~f:Sandbox.destroy;
(* All went well, these targets are no longer pending *)
pending_targets := Path.Build.Set.diff !pending_targets targets;
pending_targets := Path.Build.Set.diff !pending_targets file_targets;
exec_result

let try_to_store_to_shared_cache ~mode ~rule_digest ~action ~targets =
Expand All @@ -1494,7 +1497,7 @@ end = struct
Cached_digest.set target digest)
in
match
Path.Build.Set.to_list_map targets ~f:Dune_cache.Local.Target.create
Targets.to_list_map targets ~file:Dune_cache.Local.Target.create
|> Option.List.all
with
| None -> Fiber.return None
Expand Down Expand Up @@ -1590,7 +1593,7 @@ end = struct
rule
in
start_rule t rule;
let head_target = Path.Build.Set.choose_exn targets in
let head_target = Targets.head_exn targets in
let* execution_parameters =
match Dpath.Target_dir.of_target dir with
| Regular (With_context (_, dir))
Expand Down Expand Up @@ -1745,7 +1748,7 @@ end = struct
~cache_debug_flags:t.cache_debug_flags ~head_target miss_reason;
(* Step I. Remove stale targets both from the digest table and from
the build directory. *)
Path.Build.Set.iter targets ~f:(fun target ->
Targets.iter targets ~file:(fun target ->
Cached_digest.remove target;
Path.Build.unlink_no_err target);
(* Step II. Try to restore artifacts from the shared cache if the
Expand Down Expand Up @@ -1855,20 +1858,22 @@ end = struct
| Promote { lifetime; into; only }, (Some Automatically | None) ->
Fiber.parallel_iter_set
(module Path.Build.Set)
targets
~f:(fun path ->
(Targets.files targets)
~f:(fun target ->
let consider_for_promotion =
match only with
| None -> true
| Some pred ->
Predicate_lang.Glob.exec pred
(Path.reach (Path.build path) ~from:(Path.build dir))
(Path.reach (Path.build target) ~from:(Path.build dir))
~standard:Predicate_lang.any
in
match consider_for_promotion with
| false -> Fiber.return ()
| true ->
let in_source_tree = Path.Build.drop_build_context_exn path in
let in_source_tree =
Path.Build.drop_build_context_exn target
in
let in_source_tree =
match into with
| None -> in_source_tree
Expand Down Expand Up @@ -1910,7 +1915,7 @@ end = struct
| None -> false
| Some in_source_tree_digest -> (
match
Cached_digest.build_file path
Cached_digest.build_file target
|> Cached_digest.Digest_result.to_option
with
| None ->
Expand All @@ -1935,7 +1940,7 @@ end = struct
explicitly set the user writable bit. *)
let chmod n = n lor 0o200 in
Path.unlink_no_err (Path.source dst);
t.promote_source ~src:path ~dst ~chmod context
t.promote_source ~src:target ~dst ~chmod context
))
in
t.rule_done <- t.rule_done + 1;
Expand Down Expand Up @@ -2005,7 +2010,7 @@ end = struct
(match loc with
| Some loc -> From_dune_file loc
| None -> Internal)
~targets:(Path.Build.Set.singleton target)
~targets:(Targets.File.create target)
(Action_builder.of_thunk
{ f =
(fun mode ->
Expand Down
Loading

0 comments on commit 14b6286

Please sign in to comment.