From 1ff8a7989c996190efdf4af81fbadf74696193d5 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 21 Dec 2017 19:57:45 +0800 Subject: [PATCH] Cross compilation support In a host/target setup, all binaries that are built (including preprocessors) are ran using the host *for* building targets. Final target artifacts are compiled using the target toolchain --- src/action.ml | 48 ++++++++++++----- src/action.mli | 10 ++-- src/gen_rules.ml | 122 ++++++++++++++++++++++++++---------------- src/jbuild_load.ml | 1 + src/super_context.ml | 36 ++++++++++--- src/super_context.mli | 1 + 6 files changed, 150 insertions(+), 68 deletions(-) diff --git a/src/action.ml b/src/action.ml index 1fb48b1d..990bbe5d 100644 --- a/src/action.ml +++ b/src/action.ml @@ -327,23 +327,28 @@ module Unexpanded = struct ~map:(fun x -> (x, [])) end - let rec expand dir t ~f : Unresolved.t = + let rec expand t ~dir ~map_exe ~f : Unresolved.t = match t with | Run (prog, args) -> let args = List.concat_map args ~f:(E.strings ~dir ~f) in let prog, more_args = E.prog_and_args ~dir ~f prog in + let prog = + match prog with + | Search _ -> prog + | This path -> This (map_exe path) + in Run (prog, more_args @ args) | Chdir (fn, t) -> let fn = E.path ~dir ~f fn in - Chdir (fn, expand fn t ~f) + Chdir (fn, expand t ~dir:fn ~map_exe ~f) | Setenv (var, value, t) -> Setenv (E.string ~dir ~f var, E.string ~dir ~f value, - expand dir t ~f) + expand t ~dir ~map_exe ~f) | Redirect (outputs, fn, t) -> - Redirect (outputs, E.path ~dir ~f fn, expand dir t ~f) + Redirect (outputs, E.path ~dir ~f fn, expand t ~dir ~map_exe ~f) | Ignore (outputs, t) -> - Ignore (outputs, expand dir t ~f) - | Progn l -> Progn (List.map l ~f:(fun t -> expand dir t ~f)) + Ignore (outputs, expand t ~dir ~map_exe ~f) + | Progn l -> Progn (List.map l ~f:(fun t -> expand t ~dir ~map_exe ~f)) | Echo x -> Echo (E.string ~dir ~f x) | Cat x -> Cat (E.path ~dir ~f x) | Copy (x, y) -> @@ -406,7 +411,7 @@ module Unexpanded = struct ~special:VE.to_prog_and_args end - let rec partial_expand dir t ~f : Partial.t = + let rec partial_expand t ~dir ~map_exe ~f : Partial.t = match t with | Run (prog, args) -> let args = @@ -419,6 +424,11 @@ module Unexpanded = struct match E.prog_and_args ~dir ~f prog with | Inl (prog, more_args) -> let more_args = List.map more_args ~f:(fun x -> Inl x) in + let prog = + match prog with + | Search _ -> prog + | This path -> This (map_exe path) + in Run (Inl prog, more_args @ args) | Inr _ as prog -> Run (prog, args) @@ -427,7 +437,7 @@ module Unexpanded = struct let res = E.path ~dir ~f fn in match res with | Inl dir -> - Chdir (res, partial_expand dir t ~f) + Chdir (res, partial_expand t ~dir ~map_exe ~f) | Inr fn -> let loc = SW.loc fn in Loc.fail loc @@ -436,12 +446,12 @@ module Unexpanded = struct end | Setenv (var, value, t) -> Setenv (E.string ~dir ~f var, E.string ~dir ~f value, - partial_expand dir t ~f) + partial_expand t ~dir ~map_exe ~f) | Redirect (outputs, fn, t) -> - Redirect (outputs, E.path ~dir ~f fn, partial_expand dir t ~f) + Redirect (outputs, E.path ~dir ~f fn, partial_expand t ~dir ~map_exe ~f) | Ignore (outputs, t) -> - Ignore (outputs, partial_expand dir t ~f) - | Progn l -> Progn (List.map l ~f:(fun t -> partial_expand dir t ~f)) + Ignore (outputs, partial_expand t ~dir ~map_exe ~f) + | Progn l -> Progn (List.map l ~f:(fun t -> partial_expand t ~dir ~map_exe ~f)) | Echo x -> Echo (E.string ~dir ~f x) | Cat x -> Cat (E.path ~dir ~f x) | Copy (x, y) -> @@ -525,6 +535,20 @@ type exec_context = } let run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args = + begin match ectx.context with + | None + | Some { Context.for_host = None; _ } -> () + | Some ({ Context.for_host = Some host; _ } as target) -> + let invalid_prefix prefix = + match Path.descendant prog ~of_:(Path.of_string prefix) with + | None -> () + | Some _ -> + die "Context %s has a host %s.@.It's not possible to execute binary %a \ + in it.@.@.This is a bug and should be reported upstream." + target.name host.name Path.pp prog in + invalid_prefix ("_build/" ^ target.name); + invalid_prefix ("_build/install/" ^ target.name); + end; let stdout_to = get_std_output stdout_to in let stderr_to = get_std_output stderr_to in let env = Context.extend_env ~vars:env_extra ~env:ectx.env in diff --git a/src/action.mli b/src/action.mli index a57e0344..12fbcb9c 100644 --- a/src/action.mli +++ b/src/action.mli @@ -78,15 +78,17 @@ module Unexpanded : sig with type string = (string , String_with_vars.t) either val expand - : Path.t - -> t + : t + -> dir:Path.t + -> map_exe:(Path.t -> Path.t) -> f:(Loc.t -> String.t -> Var_expansion.t option) -> Unresolved.t end val partial_expand - : Path.t - -> t + : t + -> dir:Path.t + -> map_exe:(Path.t -> Path.t) -> f:(Loc.t -> string -> Var_expansion.t option) -> Partial.t end diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 8a2b0c5d..360265f0 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -1057,12 +1057,21 @@ Add it to your jbuild file to remove this warning. entries in let fn = - Path.relative (Path.append ctx.build_dir package_path) (package ^ ".install") + Path.relative (Path.append ctx.build_dir package_path) + (Utils.install_file ~package ~findlib_toolchain:ctx.findlib_toolchain) in let entries = local_install_rules entries ~package in SC.add_rule sctx (Build.path_set (Install.files entries) >>^ (fun () -> + let entries = + match ctx.findlib_toolchain with + | None -> entries + | Some toolchain -> + let prefix = Path.of_string (toolchain ^ "-sysroot") in + List.map entries + ~f:(Install.Entry.add_install_prefix ~prefix ~package) + in Install.gen_install_file entries) >>> Build.write_file_dyn fn) @@ -1086,22 +1095,28 @@ Add it to your jbuild file to remove this warning. install_file pkg.path pkg.name stanzas) let () = - let is_default = Path.basename ctx.build_dir = "default" in - String_map.iter (SC.packages sctx) - ~f:(fun ~key:pkg ~data:{ Package.path = src_path; _ } -> - let install_fn = pkg ^ ".install" in + let copy_to_src = + not ctx.implicit && + match ctx.kind with + | Default -> true + | Opam _ -> false + in + if not ctx.implicit then + String_map.iter (SC.packages sctx) + ~f:(fun ~key:pkg ~data:{ Package.path = src_path; _ } -> + let install_fn = Utils.install_file ~package:pkg ~findlib_toolchain:ctx.findlib_toolchain in - let ctx_path = Path.append ctx.build_dir src_path in - let ctx_install_alias = Alias.install ~dir:ctx_path in - let ctx_install_file = Path.relative ctx_path install_fn in - Alias.add_deps (SC.aliases sctx) ctx_install_alias [ctx_install_file]; + let ctx_path = Path.append ctx.build_dir src_path in + let ctx_install_alias = Alias.install ~dir:ctx_path in + let ctx_install_file = Path.relative ctx_path install_fn in + Alias.add_deps (SC.aliases sctx) ctx_install_alias [ctx_install_file]; - if is_default then begin - let src_install_alias = Alias.install ~dir:src_path in - let src_install_file = Path.relative src_path install_fn in - SC.add_rule sctx (Build.copy ~src:ctx_install_file ~dst:src_install_file); - Alias.add_deps (SC.aliases sctx) src_install_alias [src_install_file] - end) + if copy_to_src then begin + let src_install_alias = Alias.install ~dir:src_path in + let src_install_file = Path.relative src_path install_fn in + SC.add_rule sctx (Build.copy ~src:ctx_install_file ~dst:src_install_file); + Alias.add_deps (SC.aliases sctx) src_install_alias [src_install_file] + end) end let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true) @@ -1116,38 +1131,55 @@ let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true) String_map.filter packages ~f:(fun _ { Package.name; _ } -> String_set.mem name pkgs) in - List.map contexts ~f:(fun context -> - Jbuild_load.Jbuilds.eval ~context jbuilds >>| fun stanzas -> - let stanzas = - match only_packages with - | None -> stanzas - | Some pkgs -> - List.map stanzas ~f:(fun (dir, pkgs_ctx, stanzas) -> - (dir, - pkgs_ctx, - List.filter stanzas ~f:(fun stanza -> - match (stanza : Stanza.t) with - | Library { public = Some { package; _ }; _ } - | Alias { package = Some package ; _ } - | Install { package; _ } -> - String_set.mem package.name pkgs - | _ -> true))) - in - let sctx = - Super_context.create - ~context - ~aliases - ~scopes - ~file_tree - ~packages - ~filter_out_optional_stanzas_with_missing_deps - ~stanzas - in - let module M = Gen(struct let sctx = sctx end) in - (Super_context.rules sctx, (context.name, stanzas))) + let sctxs : (string, (Super_context.t * _)) Hashtbl.t = Hashtbl.create 4 in + let rec make_sctx (context : Context.t) : (_ * _) Future.t = + match Hashtbl.find sctxs context.name with + | Some r -> Future.return r + | None -> + let host = + match context.for_host with + | None -> Future.return None + | Some h -> make_sctx h >>| (fun (sctx, _) -> Some sctx) + in + let stanzas = + Jbuild_load.Jbuilds.eval ~context jbuilds >>| fun stanzas -> + match only_packages with + | None -> stanzas + | Some pkgs -> + List.map stanzas ~f:(fun (dir, pkgs_ctx, stanzas) -> + (dir, + pkgs_ctx, + List.filter stanzas ~f:(fun stanza -> + match (stanza : Stanza.t) with + | Library { public = Some { package; _ }; _ } + | Alias { package = Some package ; _ } + | Install { package; _ } -> + String_set.mem package.name pkgs + | _ -> true))) + in + Future.both host stanzas >>| fun (host, stanzas) -> + let sctx = + Super_context.create + ?host + ~context + ~aliases + ~scopes + ~file_tree + ~packages + ~filter_out_optional_stanzas_with_missing_deps + ~stanzas + in + let module M = Gen(struct let sctx = sctx end) in + Hashtbl.add sctxs ~key:context.name ~data:(sctx, stanzas); + (sctx, stanzas) in + List.map ~f:make_sctx contexts |> Future.all >>| fun l -> - let rules, context_names_and_stanzas = List.split l in + let rules, context_names_and_stanzas = + List.map l ~f:(fun (sctx, stanzas) -> + (Super_context.rules sctx, ((Super_context.context sctx).name, stanzas))) + |> List.split + in Alias.Store.unlink aliases unlink_aliases; (Alias.rules aliases @ List.concat rules, String_map.of_alist_exn context_names_and_stanzas) diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index 7a10a6ea..cec40585 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -104,6 +104,7 @@ end create_plugin_wrapper context ~exec_dir:dir ~plugin:file ~wrapper ~target:generated_jbuild in + let context = Option.value context.for_host ~default:context in let pkgs = List.map requires ~f:(Findlib.find_exn context.findlib ~required_by:[Utils.jbuild_name_in ~dir:dir]) diff --git a/src/super_context.ml b/src/super_context.ml index 9ea3a3af..6c6fbaf0 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -57,6 +57,7 @@ type t = ; ppx_drivers : (string, Path.t) Hashtbl.t ; external_dirs : (Path.t, External_dir.t) Hashtbl.t ; chdir : (Action.t, Action.t) Build.t + ; host : t option } let context t = t.context @@ -69,6 +70,8 @@ let rules t = t.rules let stanzas_to_consider_for_install t = t.stanzas_to_consider_for_install let cxx_flags t = t.cxx_flags +let host_sctx t = Option.value t.host ~default:t + let expand_var_no_root t var = String_map.find var t.vars let get_external_dir t ~dir = @@ -87,6 +90,7 @@ let resolve_program t ?hint bin = let create ~(context:Context.t) + ?host ~aliases ~scopes ~file_tree @@ -186,6 +190,7 @@ let create | Error _ -> assert false in { context + ; host ; libs ; stanzas ; packages @@ -505,7 +510,17 @@ module Action = struct acc.sdeps <- Pset.add path acc.sdeps; Some (path_exp path) - let expand_step1 sctx ~dir ~dep_kind ~scope ~targets_written_by_user t = + let map_exe sctx = + match sctx.host with + | None -> (fun exe -> exe) + | Some host -> + fun exe -> + match Path.extract_build_context_dir exe with + | Some (dir, exe) when dir = sctx.context.build_dir -> + Path.append host.context.build_dir exe + | _ -> exe + + let expand_step1 sctx ~dir ~dep_kind ~scope ~targets_written_by_user ~map_exe t = let acc = { failures = [] ; lib_deps = String_map.empty @@ -514,14 +529,17 @@ module Action = struct } in let t = - U.partial_expand dir t ~f:(fun loc key -> + U.partial_expand t ~dir ~map_exe ~f:(fun loc key -> let open Action.Var_expansion in let cos, var = parse_bang key in match String.lsplit2 var ~on:':' with | Some ("path-no-dep", s) -> Some (path_exp (Path.relative dir s)) - | Some ("exe" , s) -> static_dep_exp acc (Path.relative dir s) + | Some ("exe" , s) -> + let exe = map_exe (Path.relative dir s) in + static_dep_exp acc exe | Some ("path" , s) -> static_dep_exp acc (Path.relative dir s) | Some ("bin" , s) -> begin + let sctx = host_sctx sctx in match Artifacts.binary (artifacts sctx) s with | Ok path -> static_dep_exp acc path @@ -539,6 +557,7 @@ module Action = struct | Error fail -> add_fail acc fail end | Some ("libexec" , s) -> begin + let sctx = host_sctx sctx in let lib_dep, res = Artifacts.file_of_lib (artifacts sctx) ~loc ~from:dir s in add_lib_dep acc lib_dep dep_kind; @@ -612,9 +631,9 @@ module Action = struct in (t, acc) - let expand_step2 ~dir ~dynamic_expansions ~deps_written_by_user t = + let expand_step2 ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe t = let open Action.Var_expansion in - U.Partial.expand dir t ~f:(fun _loc key -> + U.Partial.expand t ~dir ~map_exe ~f:(fun _loc key -> match String_map.find key dynamic_expansions with | Some _ as opt -> opt | None -> @@ -633,9 +652,10 @@ module Action = struct let run sctx t ~dir ~dep_kind ~targets:targets_written_by_user ~scope : (Path.t list, Action.t) Build.t = + let map_exe = map_exe sctx in let t, forms = expand_step1 sctx t ~dir ~dep_kind ~scope - ~targets_written_by_user + ~targets_written_by_user ~map_exe in let { Action.Infer.Outcome. deps; targets } = match targets_written_by_user with @@ -689,9 +709,10 @@ module Action = struct String_map.add acc ~key:var ~data:value) in let unresolved = - expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user + expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe in Action.Unresolved.resolve unresolved ~f:(fun prog -> + let sctx = host_sctx sctx in match Artifacts.binary sctx.artifacts prog with | Ok path -> path | Error fail -> Action.Prog.Not_found.raise fail)) @@ -818,6 +839,7 @@ module PP = struct | [] -> "+none+" | _ -> String.concat names ~sep:"+" in + let sctx = host_sctx sctx in match Hashtbl.find sctx.ppx_drivers key with | Some x -> x | None -> diff --git a/src/super_context.mli b/src/super_context.mli index 8256d4eb..2e9f5253 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -22,6 +22,7 @@ type t val create : context:Context.t + -> ?host:t -> aliases:Alias.Store.t -> scopes:Scope.t list -> file_tree:File_tree.t