From d69794362fcf2e953dbdaa61b7f46b64a9de7f1a Mon Sep 17 00:00:00 2001 From: Lucas Pluvinage Date: Mon, 6 May 2019 12:03:38 +0200 Subject: [PATCH] host context resolution: topological sort to ensure no duplication and error on bad configurations. and tests. Signed-off-by: Lucas Pluvinage --- CHANGES.md | 4 + doc/usage.rst | 3 + src/context.ml | 145 +++++++++++++----- test/blackbox-tests/dune.inc | 10 ++ .../bad-configuration/dune | 6 + .../bad-configuration/dune-project | 1 + .../bad-configuration/dune-workspace | 10 ++ .../bad-configuration/p.ml | 1 + .../bad-configuration/p.opam | 0 .../custom-cross-compilation/normal/dune | 6 + .../normal/dune-project | 1 + .../normal/dune-workspace | 6 + .../custom-cross-compilation/normal/p.ml | 1 + .../custom-cross-compilation/normal/p.opam | 0 .../test-cases/custom-cross-compilation/run.t | 35 +++++ .../topological-loop/dune | 6 + .../topological-loop/dune-project | 1 + .../topological-loop/dune-workspace | 14 ++ .../topological-loop/p.ml | 1 + .../topological-loop/p.opam | 0 20 files changed, 213 insertions(+), 38 deletions(-) create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-project create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-workspace create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/p.ml create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/p.opam create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-project create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-workspace create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/normal/p.ml create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/normal/p.opam create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/run.t create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-project create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-workspace create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/p.ml create mode 100644 test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/p.opam diff --git a/CHANGES.md b/CHANGES.md index ccb38a29d35c..c1bb3d8301f8 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -43,6 +43,10 @@ unreleased - Install the `future_syntax` preprocessor as `ocaml-syntax-shims.exe` (#2125, @rgrinberg) +- In `dune-workspace` files, add the ability to choose the host context and to + create duplicates of the default context with different settings. (#2098, + @TheLortex, review by @diml and @aalekseyev) + 1.9.2 (02/05/2019) ------------------ diff --git a/doc/usage.rst b/doc/usage.rst index 8f9eef7a6016..87416b48ab14 100644 --- a/doc/usage.rst +++ b/doc/usage.rst @@ -528,6 +528,9 @@ context or can be the description of an opam switch, as follows: - ``(toolchain )`` set findlib toolchain for the context. +- ``(host )`` choose a different context to build binaries that + are meant to be executed on the host machine, such as preprocessors. + Both ``(default ...)`` and ``(opam ...)`` accept a ``targets`` field in order to setup cross compilation. See :ref:`advanced-cross-compilation` for more information. diff --git a/src/context.ml b/src/context.ml index d9736b4cf940..03b5a3b0bac0 100644 --- a/src/context.ml +++ b/src/context.ml @@ -506,11 +506,11 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ~host_c set t.ocamlmklib; end; end; - Fiber.return (host_context, t) + Fiber.return t in let implicit = not (List.mem ~set:targets Workspace.Context.Target.Native) in - let* (nat_host, native) = - create_one ~host:None ~findlib_toolchain:host_toolchain + let* native = + create_one ~host:host_context ~findlib_toolchain:host_toolchain ~implicit ~name ~merlin in let+ others = @@ -522,7 +522,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ~host_c ~findlib_toolchain:(Some findlib_toolchain) >>| Option.some) in - (nat_host, native) :: List.filter_opt others + native :: List.filter_opt others let opam_config_var t var = opam_config_var ~env:t.env ~cache:t.opam_var_cache var @@ -600,49 +600,118 @@ let create_for_opam ~root ~env ~env_nodes ~targets ~profile create ~kind:(Opam { root; switch }) ~profile ~targets ~path ~env ~env_nodes ~name ~merlin ~host_context ~host_toolchain -let resolve_host_contexts contexts = - let empty = String.Map.empty in - let map = List.fold_left - ~f:(fun map (_,(_,elem)) -> String.Map.add map elem.name elem) - ~init:empty - contexts in - List.map ~f:(fun (loc, (host, elem)) -> match host with - | None -> elem - | Some host -> ( - match String.Map.find map host with - | None -> Errors.fail loc "Undefined host context '%s' for '%s'." host elem.name - | Some ctx -> {elem with for_host=(Some ctx)} - )) - contexts +let bad_configuration_check map = + let get_host_context = function + | Workspace.Context.Default { host_context; _ } + | Workspace.Context.Opam { base={host_context; _}; _} -> host_context + in + let get_loc = function + | Workspace.Context.Default { loc; _ } + | Workspace.Context.Opam { base={loc; _}; _} -> loc + in + let check elt = match get_host_context elt with + | None -> () + | Some host -> + (let host_elt = String.Map.find_exn map host in + match get_host_context host_elt with + | None -> () + | Some host_of_host -> + Errors.fail + (get_loc host_elt) + "Context '%s' is both a host (for '%s') and a target (for '%s')." + host + (Workspace.Context.name elt) + host_of_host + ) + in + String.Map.iter + map + ~f:check + +let top_sort contexts = + let key = Workspace.Context.name + in + let map = + String.Map.of_list_map_exn + contexts + ~f:(fun x -> key x, x) + in + let deps def = + let open Workspace.Context in + match def with + | Default { host_context=(Some ctx); loc; name; _} + | Opam { base={host_context=(Some ctx); loc; name; _}; _} -> + (match String.Map.find map ctx with + | None -> + Errors.fail + loc + "Undefined host context '%s' for '%s'." + ctx + name + | Some host_ctx -> [host_ctx]) + | _ -> [] + in + bad_configuration_check map; + match Top_closure.String.top_closure ~key ~deps contexts with + | Ok top_contexts -> top_contexts + | Error _ -> assert false let create ~env (workspace : Workspace.t) = + let open Workspace.Context in let env_nodes context = { Env_nodes. context ; workspace = workspace.env } in - Fiber.parallel_map workspace.contexts ~f:(fun def -> - match def with - | Default { targets; name; host_context; profile; env = env_node ; toolchain ; loc } -> - let merlin = - workspace.merlin_context = Some (Workspace.Context.name def) - in - let host_toolchain = - match toolchain, Env.get env "OCAMLFIND_TOOLCHAIN" with - | Some t, _ -> Some t - | None, default -> default + let contexts = top_sort workspace.contexts + in + List.fold_left + contexts + ~f:(fun acc def -> + acc >>= fun (ctx_map, contexts) -> + (match def with + | Default { targets; name; host_context; profile; env = env_node ; + toolchain ; _ } -> + let merlin = + workspace.merlin_context = Some (Workspace.Context.name def) + in + let host_toolchain = + match toolchain, Env.get env "OCAMLFIND_TOOLCHAIN" with + | Some t, _ -> Some t + | None, default -> default + in + let host_context = + Option.map + host_context + ~f:(fun ctx -> String.Map.find_exn ctx_map ctx) + in + default ~env ~env_nodes:(env_nodes env_node) ~profile ~targets ~name + ~merlin ~host_context ~host_toolchain + | Opam { base = { targets; name; host_context; profile; env = env_node; + toolchain; _ } + ; switch; root; merlin } -> + let host_context = + Option.map + host_context + ~f:(fun ctx -> String.Map.find_exn ctx_map ctx) + in + create_for_opam ~root ~env_nodes:(env_nodes env_node) ~env ~profile + ~switch ~name ~merlin ~targets ~host_context + ~host_toolchain:toolchain) + >>| fun new_contexts -> + let updated_map = + List.fold_left + new_contexts + ~f:(fun map elem -> String.Map.add map elem.name elem) + ~init:ctx_map in - (default ~env ~env_nodes:(env_nodes env_node) ~profile ~targets ~name ~merlin - ~host_context ~host_toolchain - >>| fun x -> List.map ~f:(fun x -> (loc,x)) x) - | Opam { base = { targets; name; host_context; profile; env = env_node; toolchain; loc } - ; switch; root; merlin } -> - (create_for_opam ~root ~env_nodes:(env_nodes env_node) ~env ~profile - ~switch ~name ~merlin ~targets ~host_context ~host_toolchain:toolchain) - >>| fun x -> List.map ~f:(fun x -> (loc,x)) x) - >>| List.concat - >>| resolve_host_contexts + (updated_map, new_contexts @ contexts) + ) + ~init:(Fiber.return (String.Map.empty, [])) + >>| fun (_, contexts) -> contexts + + let which t s = which ~cache:t.which_cache ~path:t.path s diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index e44b00a6e01a..c933811b4349 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -127,6 +127,14 @@ test-cases/custom-build-dir (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) +(alias + (name custom-cross-compilation) + (deps (package dune) (source_tree test-cases/custom-cross-compilation)) + (action + (chdir + test-cases/custom-cross-compilation + (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) + (alias (name cxx-extension) (deps (package dune) (source_tree test-cases/cxx-extension)) @@ -1468,6 +1476,7 @@ (alias copy_files) (alias cross-compilation) (alias custom-build-dir) + (alias custom-cross-compilation) (alias cxx-extension) (alias default-targets) (alias dep-on-dir-that-does-not-exist) @@ -1645,6 +1654,7 @@ (alias copy-files-non-sub-dir-error) (alias copy_files) (alias custom-build-dir) + (alias custom-cross-compilation) (alias cxx-extension) (alias default-targets) (alias dep-on-dir-that-does-not-exist) diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune b/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune new file mode 100644 index 000000000000..e90108e95790 --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune @@ -0,0 +1,6 @@ +(executable + (name p) + (public_name p) +) + +(rule (with-stdout-to file (run ./p.exe))) diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-project b/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-project new file mode 100644 index 000000000000..42c0c1674315 --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-project @@ -0,0 +1 @@ +(lang dune 1.10) diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-workspace b/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-workspace new file mode 100644 index 000000000000..799df38e232f --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-workspace @@ -0,0 +1,10 @@ +(lang dune 1.10) +(context (default)) +(context (default + (name cross-1) + (host default) +)) +(context (default + (name cross-2) + (host cross-1) +)) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/p.ml b/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/p.ml new file mode 100644 index 000000000000..9f2d9df6b2cc --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/p.ml @@ -0,0 +1 @@ +let () = Printf.printf "%d\n" 137 diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/p.opam b/test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/p.opam new file mode 100644 index 000000000000..e69de29bb2d1 diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune b/test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune new file mode 100644 index 000000000000..e90108e95790 --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune @@ -0,0 +1,6 @@ +(executable + (name p) + (public_name p) +) + +(rule (with-stdout-to file (run ./p.exe))) diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-project b/test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-project new file mode 100644 index 000000000000..42c0c1674315 --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-project @@ -0,0 +1 @@ +(lang dune 1.10) diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-workspace b/test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-workspace new file mode 100644 index 000000000000..2e87a643fffb --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-workspace @@ -0,0 +1,6 @@ +(lang dune 1.10) +(context (default)) +(context (default + (name cross) + (host default) +)) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/normal/p.ml b/test/blackbox-tests/test-cases/custom-cross-compilation/normal/p.ml new file mode 100644 index 000000000000..9f2d9df6b2cc --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/normal/p.ml @@ -0,0 +1 @@ +let () = Printf.printf "%d\n" 137 diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/normal/p.opam b/test/blackbox-tests/test-cases/custom-cross-compilation/normal/p.opam new file mode 100644 index 000000000000..e69de29bb2d1 diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/run.t b/test/blackbox-tests/test-cases/custom-cross-compilation/run.t new file mode 100644 index 000000000000..a5876c321b63 --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/run.t @@ -0,0 +1,35 @@ + $ dune build --root ./normal --display short file @install + Entering directory 'normal' + ocamldep .p.eobjs/p.ml.d [cross] + ocamlc .p.eobjs/byte/p.{cmi,cmo,cmt} [cross] + ocamlopt .p.eobjs/native/p.{cmx,o} [cross] + ocamlopt p.exe [cross] + ocamldep .p.eobjs/p.ml.d + ocamlc .p.eobjs/byte/p.{cmi,cmo,cmt} + ocamlopt .p.eobjs/native/p.{cmx,o} + ocamlopt p.exe + p file [cross] + p file + + $ cat normal/_build/cross/file + 137 + + $ dune build --root ./bad-configuration --display short file @install + Entering directory 'bad-configuration' + File "dune-workspace", line 3, characters 9-53: + 3 | (context (default + 4 | (name cross-1) + 5 | (host default) + 6 | )) + Error: Context 'cross-1' is both a host (for 'cross-2') and a target (for 'default'). + [1] + + $ dune build --root ./topological-loop --display short file @install + Entering directory 'topological-loop' + File "dune-workspace", line 11, characters 9-53: + 11 | (context (default + 12 | (name cross-3) + 13 | (host cross-2) + 14 | )) + Error: Context 'cross-3' is both a host (for 'cross-1') and a target (for 'cross-2'). + [1] diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune b/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune new file mode 100644 index 000000000000..e90108e95790 --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune @@ -0,0 +1,6 @@ +(executable + (name p) + (public_name p) +) + +(rule (with-stdout-to file (run ./p.exe))) diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-project b/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-project new file mode 100644 index 000000000000..42c0c1674315 --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-project @@ -0,0 +1 @@ +(lang dune 1.10) diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-workspace b/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-workspace new file mode 100644 index 000000000000..589f6b3b1a1a --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-workspace @@ -0,0 +1,14 @@ +(lang dune 1.10) +(context (default)) +(context (default + (name cross-1) + (host cross-3) +)) +(context (default + (name cross-2) + (host cross-1) +)) +(context (default + (name cross-3) + (host cross-2) +)) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/p.ml b/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/p.ml new file mode 100644 index 000000000000..9f2d9df6b2cc --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/p.ml @@ -0,0 +1 @@ +let () = Printf.printf "%d\n" 137 diff --git a/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/p.opam b/test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/p.opam new file mode 100644 index 000000000000..e69de29bb2d1