From 7fc525a46332a462bb2d241b28d2fd8768f59f08 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 30 Mar 2023 01:23:04 -0700 Subject: [PATCH] fix(x-compilation): delay evaluation of `ppx_runtime_deps` until context is known Signed-off-by: Antonio Nuno Monteiro --- CHANGES.md | 3 + src/dune_rules/lib.ml | 184 ++++++++++++------ .../{ppx-cross.t => ppx-runtime-libraries.t} | 8 - .../ppx-runtime-dependencies.t/run.t | 10 +- 4 files changed, 131 insertions(+), 74 deletions(-) rename test/blackbox-tests/test-cases/custom-cross-compilation/{ppx-cross.t => ppx-runtime-libraries.t} (78%) diff --git a/CHANGES.md b/CHANGES.md index d3a9dc56edb..59811520dc0 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,9 @@ Unreleased ---------- +- Resolve `ppx_runtime_libraries` in the target context when cross compiling + (#7450, fixes #2794, @anmonteiro) + - Preliminary support for Coq compiled intefaces (`.vos` files) enabled via `(mode vos)` in `coq.theory` stanzas. This can be used in combination with `dune coq top` to obtain fast re-building of dependencies (with no checking diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index be8ebd790f1..1fa3e83d4ba 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -299,7 +299,7 @@ module T = struct ; (* [requires] is contains all required libraries, including the ones mentioned in [re_exports]. *) requires : t list Resolve.t - ; ppx_runtime_deps : t list Resolve.t + ; ppx_runtime_deps_host : t list Resolve.t Memo.Lazy.t ; pps : t list Resolve.t ; resolved_selects : Resolved_select.t list Resolve.t ; implements : t Resolve.t option @@ -353,6 +353,30 @@ module Hidden = struct { lib = info; reason = "unsatisfied 'exist_if'"; path } end +module Private_deps = struct + type t = + | From_same_project of [ `Public | `Private_package ] + | Allow_all + + let equal a b = + match (a, b) with + | Allow_all, Allow_all + | From_same_project `Public, From_same_project `Public + | From_same_project `Private_package, From_same_project `Private_package -> + true + | _ -> false + + let check t ~loc ~lib = + match t with + | Allow_all -> Ok lib + | From_same_project kind -> ( + match Lib_info.status lib.info with + | Private (_, Some _) -> Ok lib + | Private (_, None) -> + Error (Error.private_deps_not_allowed ~kind ~loc lib.info) + | _ -> Ok lib) +end + module Status = struct type t = | Found of lib @@ -374,6 +398,8 @@ type db = { parent : db option ; host : db Memo.Lazy.t option ; resolve : Lib_name.t -> resolve_result Memo.t + ; resolve_ppx_runtime_deps : + (Path.t Lib_info.t * Private_deps.t, t list Resolve.t) Memo.Table.t ; all : Lib_name.t list Memo.Lazy.t ; lib_config : Lib_config.t } @@ -399,7 +425,7 @@ let implements t = Option.map ~f:Memo.return t.implements let requires t = Memo.return t.requires -let ppx_runtime_deps t = Memo.return t.ppx_runtime_deps +let ppx_runtime_deps t = Memo.Lazy.force t.ppx_runtime_deps_host let pps t = Memo.return t.pps @@ -603,20 +629,6 @@ end = struct { stack = x :: t.stack; seen = Id.Set.add t.seen x; implements_via } end -type private_deps = - | From_same_project of [ `Public | `Private_package ] - | Allow_all - -let check_private_deps lib ~loc ~(private_deps : private_deps) = - match private_deps with - | Allow_all -> Ok lib - | From_same_project kind -> ( - match Lib_info.status lib.info with - | Private (_, Some _) -> Ok lib - | Private (_, None) -> - Error (Error.private_deps_not_allowed ~kind ~loc lib.info) - | _ -> Ok lib) - module Vlib : sig (** Make sure that for every virtual library in the list there is at most one corresponding implementation. @@ -776,7 +788,10 @@ module rec Resolve_names : sig val find_internal : db -> Lib_name.t -> Status.t Memo.t val resolve_dep : - db -> Loc.t * Lib_name.t -> private_deps:private_deps -> lib Resolve.Memo.t + db + -> Loc.t * Lib_name.t + -> private_deps:Private_deps.t + -> lib Resolve.Memo.t val resolve_name : db -> Lib_name.t -> Status.t Memo.t @@ -785,7 +800,7 @@ module rec Resolve_names : sig val resolve_simple_deps : db -> (Loc.t * Lib_name.t) list - -> private_deps:private_deps + -> private_deps:Private_deps.t -> t list Resolve.Memo.t type resolved = @@ -798,7 +813,7 @@ module rec Resolve_names : sig val resolve_deps_and_add_runtime_deps : db -> Lib_dep.t list - -> private_deps:private_deps + -> private_deps:Private_deps.t -> pps:(Loc.t * Lib_name.t) list -> dune_version:Dune_lang.Syntax.Version.t option -> resolved Memo.t @@ -832,13 +847,13 @@ end = struct let instantiate_impl (db, name, info, hidden) = let open Memo.O in let unique_id = Id.make ~name ~path:(Lib_info.src_dir info) in - let status = Lib_info.status info in let private_deps = - match status with + match Lib_info.status info with (* [Allow_all] is used for libraries that are installed because we don't have to check it again. It has been checked when compiling the libraries before their installation *) - | Installed_private | Private (_, None) | Installed -> Allow_all + | Installed_private | Private (_, None) | Installed -> + Private_deps.Allow_all | Private (_, Some _) -> From_same_project `Private_package | Public (_, _) -> From_same_project `Public in @@ -948,16 +963,17 @@ end = struct let+ impl = impl in impl :: requires) in - let* ppx_runtime_deps = - Lib_info.ppx_runtime_deps info |> resolve_simple_deps db ~private_deps - in - let src_dir = Lib_info.src_dir info in let map_error x = + let src_dir = Lib_info.src_dir info in Resolve.push_stack_frame x ~human_readable_description:(fun () -> Dep_path.Entry.Lib.pp { name; path = src_dir }) in + let ppx_runtime_deps_host = + Memo.lazy_ (fun () -> + Memo.exec db.resolve_ppx_runtime_deps (info, private_deps) + |> Memo.map ~f:map_error) + in let requires = map_error requires in - let ppx_runtime_deps = map_error ppx_runtime_deps in let* project = let status = Lib_info.status info in match Lib_info.Status.project status with @@ -978,7 +994,7 @@ end = struct ; name ; unique_id ; requires - ; ppx_runtime_deps + ; ppx_runtime_deps_host ; pps ; resolved_selects ; re_exports @@ -994,27 +1010,25 @@ end = struct }) in let t = Lazy.force t in - let res = - let hidden = - match hidden with - | Some _ -> hidden - | None -> ( - let enabled = Lib_info.enabled info in - match enabled with - | Normal -> None - | Disabled_because_of_enabled_if -> Some "unsatisfied 'enabled_if'" - | Optional -> - (* TODO this could be made lazier *) - let requires = Resolve.is_ok requires in - let ppx_runtime_deps = Resolve.is_ok t.ppx_runtime_deps in - if requires && ppx_runtime_deps then None - else Some "optional with unavailable dependencies") - in + let+ hidden = match hidden with - | None -> Status.Found t - | Some reason -> Hidden (Hidden.of_lib t ~reason) + | Some _ -> Memo.return hidden + | None -> ( + let enabled = Lib_info.enabled info in + match enabled with + | Normal -> Memo.return None + | Disabled_because_of_enabled_if -> + Memo.return (Some "unsatisfied 'enabled_if'") + | Optional -> + (* TODO this could be made lazier *) + let requires = Resolve.is_ok requires in + let+ ppx_runtime_deps = ppx_runtime_deps t >>| Resolve.is_ok in + if requires && ppx_runtime_deps then None + else Some "optional with unavailable dependencies") in - Memo.return res + match hidden with + | None -> Status.Found t + | Some reason -> Hidden (Hidden.of_lib t ~reason) let memo = let module Input = struct @@ -1044,7 +1058,7 @@ end = struct let open Memo.O in find_internal db name >>= function | Found lib -> - Resolve.Memo.of_result (check_private_deps lib ~loc ~private_deps) + Resolve.Memo.of_result (Private_deps.check private_deps ~loc ~lib) | Not_found -> Error.not_found ~loc ~name | Invalid why -> Resolve.Memo.of_result (Error why) | Hidden h -> Hidden.error h ~loc ~name @@ -1285,12 +1299,17 @@ end = struct in let pps = let* pps = + let open Memo.O in let* db_host = match db.host with - | None -> Resolve.Memo.return db - | Some host -> Resolve.Memo.lift_memo (Memo.Lazy.force host) + | None -> Memo.return db + | Some host -> + (* PPXes run in the host context, so their dependencies have to + be resolved accordingly. *) + Memo.Lazy.force host in Resolve.Memo.List.map pps ~f:(fun (loc, name) -> + let open Resolve.Memo.O in let* lib = resolve_dep db_host (loc, name) ~private_deps:Allow_all in @@ -1303,12 +1322,25 @@ end = struct in let runtime_deps = let* pps = pps in - Resolve.List.concat_map pps ~f:(fun pp -> - let open Resolve.O in - let* ppx_runtime_deps = pp.ppx_runtime_deps in + Resolve.Memo.List.concat_map pps ~f:(fun pp -> + let* ppx_runtime_deps = + match db.host with + | None -> ppx_runtime_deps pp + | Some _host -> + (* (ppx_runtime_libraries ...) run in the target context, so + these dependencies need to be resolved here rather than at + instantiation of the ppx library (in the host context). *) + Memo.exec db.resolve_ppx_runtime_deps (pp.info, private_deps) + |> Memo.map ~f:(fun x -> + Resolve.push_stack_frame x + ~human_readable_description:(fun () -> + Dep_path.Entry.Lib.pp + { name = pp.name; path = Lib_info.src_dir pp.info })) + in Resolve.List.map ppx_runtime_deps ~f:(fun dep -> - check_private_deps ~loc ~private_deps dep |> Resolve.of_result)) - |> Memo.return + Private_deps.check private_deps ~lib:dep ~loc + |> Resolve.of_result) + |> Memo.return) in { runtime_deps; pps } @@ -1634,7 +1666,7 @@ let descriptive_closure (l : lib list) ~with_pps : lib list Memo.t = let* todo = if with_pps then register_work todo lib.pps else Memo.return todo in - let* todo = register_work todo lib.ppx_runtime_deps in + let* todo = ppx_runtime_deps lib >>= register_work todo in let* todo = register_work todo lib.requires in work todo acc in @@ -1734,8 +1766,42 @@ module DB = struct type t = db - let create ~parent ~host ~resolve ~all ~lib_config () = - { parent; host; resolve; all = Memo.lazy_ all; lib_config } + let create = + let module Input = struct + type t = Path.t Lib_info.t * Private_deps.t + + let to_dyn = Dyn.opaque + + let hash x = Poly.hash x + + let equal (t, private_deps) (t', private_deps') = + equal t t' && Private_deps.equal private_deps private_deps' + end in + let resolve_ppx_runtime_deps db = + let resolve_ppx_runtime_deps_impl (info, private_deps) = + Resolve_names.resolve_simple_deps (Lazy.force db) + (Lib_info.ppx_runtime_deps info) + ~private_deps + in + Memo.create "lib-resolve-ppx-runtime-libraries" + ~input:(module Input) + resolve_ppx_runtime_deps_impl + ~human_readable_description:(fun (info, _private_deps) -> + Dep_path.Entry.Lib.pp + { name = Lib_info.name info; path = Lib_info.src_dir info }) + in + fun ~parent ~host ~resolve ~all ~lib_config () -> + let rec db = + lazy + { parent + ; host + ; resolve + ; resolve_ppx_runtime_deps = resolve_ppx_runtime_deps db + ; all = Memo.lazy_ all + ; lib_config + } + in + Lazy.force db let create_from_findlib ~host findlib = let lib_config = Findlib.lib_config findlib in @@ -1929,7 +1995,7 @@ let to_dune_lib ({ info; _ } as lib) ~modules ~foreign_objects use_public_name ~info_field:(Lib_info.default_implementation info) ~lib_field:(Option.map ~f:Memo.Lazy.force lib.default_implementation) - and+ ppx_runtime_deps = Memo.return lib.ppx_runtime_deps + and+ ppx_runtime_deps = ppx_runtime_deps lib and+ requires = Memo.return lib.requires and+ re_exports = Memo.return lib.re_exports in let ppx_runtime_deps = add_loc ppx_runtime_deps in diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/ppx-cross.t b/test/blackbox-tests/test-cases/custom-cross-compilation/ppx-runtime-libraries.t similarity index 78% rename from test/blackbox-tests/test-cases/custom-cross-compilation/ppx-cross.t rename to test/blackbox-tests/test-cases/custom-cross-compilation/ppx-runtime-libraries.t index 3de9a567c9e..971bc0372b7 100644 --- a/test/blackbox-tests/test-cases/custom-cross-compilation/ppx-cross.t +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/ppx-runtime-libraries.t @@ -57,12 +57,4 @@ In the ppx, removing `ppx_runtime_libraries` makes the test pass $ touch lib2/lib2.ml $ dune build @install -x foo - Error: Conflict between the following libraries: - - "ppx-cross.lib1" in _build/default.foo/lib1 - - "ppx-cross.lib1" in _build/default/lib1 - -> required by _build/default.foo/lib2/.lib2.objs/byte/lib2.cmt - -> required by _build/install/default.foo/lib/ppx-cross/lib2/lib2.cmt - -> required by _build/default.foo/ppx-cross-foo.install - -> required by alias install (context default.foo) - [1] diff --git a/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t b/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t index d0796bcfd73..3c57cb66e89 100644 --- a/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t +++ b/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t @@ -8,7 +8,8 @@ Handling ppx_runtime_libraries dependencies correctly $ chmod +x sdune ---------------------------------------------------------------------------------- -* Incorrect cycle detection due to ppx_runtime_libraries (TODO: fix this bug!) +ppx_runtime_libraries detection is delayed until they're used so this doesn't +cause a dependency cycle $ cat >dune-project < (lang dune 2.0) @@ -59,12 +60,7 @@ Handling ppx_runtime_libraries dependencies correctly > EOF $ ./sdune exec bin/main.exe - Error: Dependency cycle between: - library "b" in _build/default - -> library "a" in _build/default - -> library "c" in _build/default - -> library "b" in _build/default - [1] + Should print 3: 3 ---------------------------------------------------------------------------------- * Ppx rewriters (and their ppx_runtime_libraries information) are collected recursively