Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

fix: resolve installed binaries to local paths #9496

Merged
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 3 additions & 0 deletions doc/changes/9496.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
- Resolve various public binaries to their build location, rather than to where
they're copied in the `_build/install` directory (#9496, fixes #7908,
@rgrinberg).
6 changes: 6 additions & 0 deletions otherlibs/stdune/src/map.ml
Original file line number Diff line number Diff line change
Expand Up @@ -44,6 +44,12 @@ module Make (Key : Key) : S with type key = Key.t = struct
let merge a b ~f = merge a b ~f
let union a b ~f = union a b ~f

let union_all maps ~f =
match maps with
| [] -> empty
| init :: maps -> List.fold_left maps ~init ~f:(fun acc map -> union acc map ~f)
;;

let union_exn a b =
union a b ~f:(fun key _ _ ->
Code_error.raise
Expand Down
1 change: 1 addition & 0 deletions otherlibs/stdune/src/map_intf.ml
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ module type S = sig
val add_multi : 'a list t -> key -> 'a -> 'a list t
val merge : 'a t -> 'b t -> f:(key -> 'a option -> 'b option -> 'c option) -> 'c t
val union : 'a t -> 'a t -> f:(key -> 'a -> 'a -> 'a option) -> 'a t
val union_all : 'a t list -> f:(key -> 'a -> 'a -> 'a option) -> 'a t

(** Like [union] but raises a code error if a key appears in both maps. *)
val union_exn : 'a t -> 'a t -> 'a t
Expand Down
75 changes: 54 additions & 21 deletions src/dune_rules/artifacts.ml
Original file line number Diff line number Diff line change
Expand Up @@ -4,49 +4,83 @@ open Memo.O
let bin_dir_basename = ".bin"
let local_bin p = Path.Build.relative p bin_dir_basename

type origin =
{ binding : File_binding.Unexpanded.t
; dir : Path.Build.t
; dst : Path.Local.t
}

type where =
| Install_dir
| Original_path

type path =
| Resolved of Path.Build.t
| Origin of origin

type local_bins = path Filename.Map.t

type t =
{ context : Context.t
; (* Mapping from executable names to their actual path in the workspace.
The keys are the executable names without the .exe, even on Windows.
Enumerating binaries from install stanzas may involve expanding globs,
but the artifacts database is depended on by the logic which expands
globs. The computation of this field is deferred to break the cycle. *)
local_bins : Path.Build.t Filename.Map.t Memo.Lazy.t
local_bins : local_bins Memo.Lazy.t
}

let force { local_bins; _ } =
let+ (_ : Path.Build.t Filename.Map.t) = Memo.Lazy.force local_bins in
let+ (_ : local_bins) = Memo.Lazy.force local_bins in
()
;;

let expand = Fdecl.create Dyn.opaque

let analyze_binary t name =
match Filename.is_relative name with
| false -> Memo.return (Some (Path.of_filename_relative_to_initial_cwd name))
| false -> Memo.return (`Resolved (Path.of_filename_relative_to_initial_cwd name))
| true ->
let* local_bins = Memo.Lazy.force t.local_bins in
(match Filename.Map.find local_bins name with
| Some path -> Memo.return (Some (Path.build path))
| None -> Context.which t.context name)
| Some (Resolved p) -> Memo.return (`Resolved (Path.build p))
| Some (Origin o) -> Memo.return (`Origin o)
| None ->
Context.which t.context name
>>| (function
| None -> `None
| Some path -> `Resolved path))
;;

let binary t ?hint ~loc name =
let binary t ?hint ?(where = Install_dir) ~loc name =
analyze_binary t name
>>| function
| Some path -> Ok path
| None ->
>>= function
| `Resolved path -> Memo.return @@ Ok path
| `None ->
let context = Context.name t.context in
Error (Action.Prog.Not_found.create ~program:name ?hint ~context ~loc ())
Memo.return
@@ Error (Action.Prog.Not_found.create ~program:name ?hint ~context ~loc ())
| `Origin { dir; binding; dst } ->
(match where with
| Install_dir ->
let install_dir = Install.Context.bin_dir ~context:(Context.name t.context) in
Memo.return @@ Ok (Path.build @@ Path.Build.append_local install_dir dst)
| Original_path ->
let+ expanded =
File_binding.Unexpanded.expand
binding
~dir
~f:(Fdecl.get expand ~context:t.context ~dir)
in
let src = File_binding.Expanded.src expanded in
Ok (Path.build src))
;;

let binary_available t name =
analyze_binary t name
>>= function
| None -> Memo.return false
| Some path ->
(match path with
| External e -> Fs_memo.file_exists @@ External e
| In_source_tree e -> Fs_memo.file_exists @@ In_source_dir e
| In_build_dir _ -> Memo.return true)
>>| function
| `None -> false
| `Resolved _ | `Origin _ -> true
;;

let add_binaries t ~dir l =
Expand All @@ -55,7 +89,7 @@ let add_binaries t ~dir l =
let+ local_bins = Memo.Lazy.force t.local_bins in
List.fold_left l ~init:local_bins ~f:(fun acc fb ->
let path = File_binding.Expanded.dst_path fb ~dir:(local_bin dir) in
Filename.Map.set acc (Path.Build.basename path) path))
Filename.Map.set acc (Path.Build.basename path) (Resolved path)))
in
{ t with local_bins }
;;
Expand All @@ -70,10 +104,9 @@ let create =
let local_bins =
Memo.lazy_ (fun () ->
let+ local_bins = Memo.Lazy.force local_bins in
Path.Build.Set.fold local_bins ~init:Filename.Map.empty ~f:(fun path acc ->
let name = Path.Build.basename path in
Filename.Map.foldi local_bins ~init:Filename.Map.empty ~f:(fun name origin acc ->
let key = drop_suffix name in
Filename.Map.set acc key path))
Filename.Map.set acc key (Origin origin)))
in
{ context; local_bins }
;;
23 changes: 21 additions & 2 deletions src/dune_rules/artifacts.mli
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,16 @@ open Import

type t

type origin =
{ binding : File_binding.Unexpanded.t
; dir : Path.Build.t
; dst : Path.Local.t
}

type where =
| Install_dir
| Original_path

(** Force the computation of the internal list of binaries. This is exposed as
some error checking is only performed during this computation and some
errors will go unreported unless this computation takes place. *)
Expand All @@ -15,8 +25,17 @@ val local_bin : Path.Build.t -> Path.Build.t

(** A named artifact that is looked up in the PATH if not found in the tree If
the name is an absolute path, it is used as it. *)
val binary : t -> ?hint:string -> loc:Loc.t option -> string -> Action.Prog.t Memo.t
val binary
: t
-> ?hint:string
-> ?where:where
-> loc:Loc.t option
-> Filename.t
-> Action.Prog.t Memo.t

val binary_available : t -> string -> bool Memo.t
val add_binaries : t -> dir:Path.Build.t -> File_binding.Expanded.t list -> t
val create : Context.t -> local_bins:Path.Build.Set.t Memo.Lazy.t -> t
val create : Context.t -> local_bins:origin Filename.Map.t Memo.Lazy.t -> t

val expand
: (context:Context.t -> dir:Path.Build.t -> String_with_vars.t -> string Memo.t) Fdecl.t
22 changes: 11 additions & 11 deletions src/dune_rules/artifacts_db.ml
Original file line number Diff line number Diff line change
Expand Up @@ -36,8 +36,8 @@ let available_exes ~dir (exes : Dune_file.Executables.t) =
;;

let get_installed_binaries ~(context : Context.t) stanzas =
let merge _ _ x = Some x in
let open Memo.O in
let install_dir = Install.Context.bin_dir ~context:(Context.name context) in
let expand ~dir sw = Expander.With_reduced_var_set.expand ~context ~dir sw in
let expand_str ~dir sw = Expander.With_reduced_var_set.expand_str ~context ~dir sw in
let expand_str_partial ~dir sw =
Expand All @@ -57,12 +57,14 @@ let get_installed_binaries ~(context : Context.t) stanzas =
~expand:(expand_str ~dir)
~expand_partial:(expand_str_partial ~dir)
in
let p = Path.Local.of_string (Install.Entry.Dst.to_string p) in
if Path.Local.is_root (Path.Local.parent_exn p)
then Some (Path.Build.append_local install_dir p)
let dst = Path.Local.of_string (Install.Entry.Dst.to_string p) in
if Path.Local.is_root (Path.Local.parent_exn dst)
then (
let origin = { Artifacts.binding = fb; dir; dst } in
Some (Path.Local.basename dst, origin))
else None)
>>| List.filter_opt
>>| Path.Build.Set.of_list
>>| Filename.Map.of_list_reduce ~f:(fun _ y -> y)
in
Memo.List.map d.stanzas ~f:(fun stanza ->
match Stanza.repr stanza with
Expand All @@ -80,12 +82,10 @@ let get_installed_binaries ~(context : Context.t) stanzas =
| false -> Memo.return true
| true -> available_exes ~dir exes)
in
if available
then binaries_from_install files
else Memo.return Path.Build.Set.empty
| _ -> Memo.return Path.Build.Set.empty)
>>| Path.Build.Set.union_all)
>>| Path.Build.Set.union_all
if available then binaries_from_install files else Memo.return Filename.Map.empty
| _ -> Memo.return Filename.Map.empty)
>>| Filename.Map.union_all ~f:merge)
>>| Filename.Map.union_all ~f:merge
;;

let all =
Expand Down
1 change: 1 addition & 0 deletions src/dune_rules/cinaps.ml
Original file line number Diff line number Diff line change
Expand Up @@ -127,6 +127,7 @@ let gen_rules sctx t ~dir ~scope =
Super_context.resolve_program
sctx
~dir
~where:Original_path
~loc:(Some loc)
name
~hint:"opam install cinaps"
Expand Down
2 changes: 1 addition & 1 deletion src/dune_rules/coq/coq_config.ml
Original file line number Diff line number Diff line change
Expand Up @@ -269,7 +269,7 @@ let by_name { version_info; coqlib; coqcorelib; coq_native_compiler_default } na
let expand source macro artifacts_host =
let s = Pform.Macro_invocation.Args.whole macro in
let open Memo.O in
let* coqc = Artifacts.binary artifacts_host ~loc:None "coqc" in
let* coqc = Artifacts.binary artifacts_host ~where:Original_path ~loc:None "coqc" in
let+ t = make ~coqc in
match t with
| Error msg ->
Expand Down
4 changes: 4 additions & 0 deletions src/dune_rules/coq/coq_rules.ml
Original file line number Diff line number Diff line change
Expand Up @@ -95,6 +95,7 @@ let coqc ~loc ~dir ~sctx =
Super_context.resolve_program_memo
sctx
"coqc"
~where:Original_path
~dir
~loc:(Some loc)
~hint:"opam install coq"
Expand Down Expand Up @@ -488,6 +489,7 @@ let setup_coqdep_for_theory_rule
sctx
"coqdep"
~dir
~where:Original_path
~loc:(Some loc)
~hint:"opam install coq"
in
Expand Down Expand Up @@ -746,6 +748,7 @@ let setup_coqdoc_rules ~sctx ~dir ~theories_deps (s : Coq_stanza.Theory.t) coq_m
sctx
"coqdoc"
~dir
~where:Original_path
~loc:(Some loc)
~hint:"opam install coq"
in
Expand Down Expand Up @@ -1075,6 +1078,7 @@ let setup_coqpp_rules ~sctx ~dir ({ loc; modules } : Coq_stanza.Coqpp.t) =
Super_context.resolve_program_memo
sctx
"coqpp"
~where:Original_path
~dir
~loc:(Some loc)
~hint:"opam install coq"
Expand Down
5 changes: 5 additions & 0 deletions src/dune_rules/expander.ml
Original file line number Diff line number Diff line change
Expand Up @@ -925,3 +925,8 @@ let expand_lock ~base expander (Locks.Lock sw) =
let expand_locks ~base expander locks =
Memo.List.map locks ~f:(expand_lock ~base expander) |> Action_builder.of_memo
;;

let () =
Fdecl.set Artifacts.expand (fun ~context ~dir sw ->
With_reduced_var_set.expand_str ~context ~dir sw)
;;
1 change: 1 addition & 0 deletions src/dune_rules/fdo.ml
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,7 @@ let ocamlfdo_binary sctx dir =
Super_context.resolve_program
sctx
~dir
~where:Original_path
~loc:None
"ocamlfdo"
~hint:"opam install ocamlfdo"
Expand Down
8 changes: 7 additions & 1 deletion src/dune_rules/inline_tests.ml
Original file line number Diff line number Diff line change
Expand Up @@ -263,7 +263,13 @@ include Sub_system.Register_end_point (struct
let+ flags = flags in
Action.run (Ok exe) flags
| Some runner ->
let* prog = Super_context.resolve_program ~dir sctx ~loc:(Some loc) runner
let* prog =
Super_context.resolve_program
~dir
sctx
~where:Original_path
~loc:(Some loc)
runner
and* flags = flags in
let action =
Action.run prog (Path.reach exe ~from:(Path.build dir) :: flags)
Expand Down
8 changes: 7 additions & 1 deletion src/dune_rules/jsoo/jsoo_rules.ml
Original file line number Diff line number Diff line change
Expand Up @@ -185,7 +185,13 @@ let in_obj_dir' ~obj_dir ~config args =
;;

let jsoo ~dir sctx =
Super_context.resolve_program sctx ~dir ~loc:None ~hint:install_jsoo_hint "js_of_ocaml"
Super_context.resolve_program
sctx
~dir
~loc:None
~where:Original_path
~hint:install_jsoo_hint
"js_of_ocaml"
;;

type sub_command =
Expand Down
1 change: 1 addition & 0 deletions src/dune_rules/mdx.ml
Original file line number Diff line number Diff line change
Expand Up @@ -509,6 +509,7 @@ let gen_rules t ~sctx ~dir ~scope ~expander =
let mdx_prog =
Super_context.resolve_program
sctx
~where:Original_path
~dir
~loc:(Some t.loc)
~hint:"opam install mdx"
Expand Down
8 changes: 7 additions & 1 deletion src/dune_rules/melange/melange_binary.ml
Original file line number Diff line number Diff line change
@@ -1,7 +1,13 @@
open Import

let melc sctx ~loc ~dir =
Super_context.resolve_program_memo sctx ~loc ~dir ~hint:"opam install melange" "melc"
Super_context.resolve_program_memo
sctx
~loc
~dir
~where:Original_path
~hint:"opam install melange"
"melc"
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@anmonteiro I tweaked the resolution of melange here as well. It shouldn't affect anything, but could in theory help with some odd cycles

;;

let where =
Expand Down
8 changes: 7 additions & 1 deletion src/dune_rules/menhir/menhir_rules.ml
Original file line number Diff line number Diff line change
Expand Up @@ -119,7 +119,13 @@ module Run (P : PARAMS) = struct
(* Rule generation. *)

let menhir_binary =
Super_context.resolve_program sctx ~dir "menhir" ~loc:None ~hint:"opam install menhir"
Super_context.resolve_program
sctx
~dir
~where:Original_path
"menhir"
~loc:None
~hint:"opam install menhir"
;;

(* Reminder (from command.mli):
Expand Down
8 changes: 7 additions & 1 deletion src/dune_rules/odoc.ml
Original file line number Diff line number Diff line change
Expand Up @@ -247,7 +247,13 @@ let odoc_base_flags quiet build_dir =
;;

let odoc_program sctx dir =
Super_context.resolve_program sctx ~dir "odoc" ~loc:None ~hint:"opam install odoc"
Super_context.resolve_program
sctx
~dir
~where:Original_path
"odoc"
~loc:None
~hint:"opam install odoc"
;;

let run_odoc sctx ~dir command ~quiet ~flags_for args =
Expand Down
8 changes: 4 additions & 4 deletions src/dune_rules/super_context.ml
Original file line number Diff line number Diff line change
Expand Up @@ -231,13 +231,13 @@ let add_alias_action t alias ~dir ~loc action =

let env_node = Env_tree.get_node

let resolve_program_memo t ~dir ?hint ~loc bin =
let resolve_program_memo t ~dir ?where ?hint ~loc bin =
let* artifacts = Env_tree.artifacts_host t ~dir in
Artifacts.binary ?hint ~loc artifacts bin
Artifacts.binary ?hint ?where ~loc artifacts bin
;;

let resolve_program t ~dir ?hint ~loc bin =
Action_builder.of_memo @@ resolve_program_memo t ~dir ?hint ~loc bin
let resolve_program t ~dir ?where ?hint ~loc bin =
Action_builder.of_memo @@ resolve_program_memo t ~dir ?where ?hint ~loc bin
;;

let make_default_env_node
Expand Down
Loading
Loading