From 6d63bc561db808b07078711f0554522d8999514f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Bobot?= Date: Fri, 27 Mar 2020 22:28:50 +0100 Subject: [PATCH] Add relocatable option to dune install MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - But since findlib loads all the dependencies even the one already linked it is not sufficient to copy only the META of the dependencies not linked in the binary which are the one really needed Signed-off-by: François Bobot --- bin/install_uninstall.ml | 17 +++++++- otherlibs/cram/bin/sanitize.ml | 3 +- otherlibs/sites_locations/src/dune | 6 +++ .../src/plugins/sites_locations_plugins.ml | 13 ++++-- .../sites_locations/src/sites_locations.ml | 29 ++++++++++++- .../sites_locations/src/sites_locations.mli | 1 + .../src/sites_locations_data.mli | 1 + otherlibs/sites_locations/test/run.t | 41 +++++++++++++++++++ src/dune/artifact_substitution.ml | 20 ++++++++- src/dune/artifact_substitution.mli | 3 ++ src/dune/build_system.ml | 1 + src/dune/dune_file.ml | 4 +- src/dune/dune_file.mli | 1 + src/dune/generate_module_rules.ml | 4 ++ src/dune/lib_info.ml | 34 ++++++++++++++- src/dune/lib_info.mli | 6 +++ src/dune/link_time_code_gen.ml | 24 ++++++++++- .../artifact_substitution.ml | 1 + 18 files changed, 196 insertions(+), 13 deletions(-) create mode 100644 otherlibs/sites_locations/src/sites_locations_data.mli diff --git a/bin/install_uninstall.ml b/bin/install_uninstall.ml index fc36b3cf164..2c1c29f0cf1 100644 --- a/bin/install_uninstall.ml +++ b/bin/install_uninstall.ml @@ -69,6 +69,7 @@ module type File_operations = sig -> special_file:Special_file.t option -> package:Package.Name.t -> get_location:(Dune.Section.t -> Package.Name.t -> Stdune.Path.t) + -> is_relocatable:(Path.t option) -> unit Fiber.t val mkdir_p : Path.t -> unit @@ -83,7 +84,8 @@ module type Workspace = sig end module File_ops_dry_run : File_operations = struct - let copy_file ~src ~dst ~executable ~special_file:_ ~package:_ ~get_location:_ = + let copy_file ~src ~dst ~executable ~special_file:_ ~package:_ ~get_location:_ + ~is_relocatable:_ = Format.printf "Copying %s to %s (executable: %b)\n" (Path.to_string_maybe_quoted src) (Path.to_string_maybe_quoted dst) @@ -219,7 +221,8 @@ module File_ops_real (W : Workspace) : File_operations = struct Format.pp_print_cut ppf ()); Format.pp_close_box ppf ()) - let copy_file ~src ~dst ~executable ~special_file ~package ~get_location = + let copy_file ~src ~dst ~executable ~special_file ~package ~get_location + ~is_relocatable = let chmod = if executable then fun _ -> @@ -244,6 +247,7 @@ module File_ops_real (W : Workspace) : File_operations = struct get_vcs; get_location; get_localPath=(fun _ -> None); + is_relocatable; } ~input:(input ic) ~output:(output oc)) @@ -356,6 +360,11 @@ let install_uninstall ~what = value & flag & info [ "dry-run" ] ~doc:"Only display the file operations that would be performed.") + and+ relocatable = + Arg.( + value & flag + & info [ "relocatable" ] + ~doc:"Make the binaries relocatable (the installation directory can be moved).") and+ pkgs = Arg.(value & pos_all package_name [] name_) and+ context = Arg.( @@ -465,6 +474,9 @@ let install_uninstall ~what = get_dirs context ~prefix_from_command_line ~libdir_from_command_line in + let is_relocatable = + if relocatable then Some prefix else None + in Fiber.sequential_iter entries_per_package ~f:(fun (package, entries) -> let paths = @@ -496,6 +508,7 @@ let install_uninstall ~what = in Ops.copy_file ~src:entry.src ~dst ~executable ~special_file ~package ~get_location + ~is_relocatable ) else ( Ops.remove_if_exists dst; files_deleted_in := Path.Set.add !files_deleted_in dir; diff --git a/otherlibs/cram/bin/sanitize.ml b/otherlibs/cram/bin/sanitize.ml index b57c4ac5bcd..033a0254f68 100644 --- a/otherlibs/cram/bin/sanitize.ml +++ b/otherlibs/cram/bin/sanitize.ml @@ -15,7 +15,8 @@ let rewrite_paths = exit 2 | Ok map -> let abs_path_re = - Re.(compile (seq [ char '/'; rep1 (diff any (set " \n\r\t")) ])) + let not_dir = Printf.sprintf " \n\r\t%c" Bin.path_sep in + Re.(compile (seq [ char '/'; rep1 (diff any (set not_dir)) ])) in fun s -> Re.replace abs_path_re s ~f:(fun g -> diff --git a/otherlibs/sites_locations/src/dune b/otherlibs/sites_locations/src/dune index 17cd49c7135..36f7cfa2ed3 100644 --- a/otherlibs/sites_locations/src/dune +++ b/otherlibs/sites_locations/src/dune @@ -1,4 +1,10 @@ (library (name sites_locations) (public_name dune-sites-locations) + (modules_without_implementation sites_locations_data) + ; (private_modules sites_locations_data) + (special_builtin_support + (sites_locations + (data_module sites_locations_data) + )) ) diff --git a/otherlibs/sites_locations/src/plugins/sites_locations_plugins.ml b/otherlibs/sites_locations/src/plugins/sites_locations_plugins.ml index 09610ac3c7b..31b33b36339 100644 --- a/otherlibs/sites_locations/src/plugins/sites_locations_plugins.ml +++ b/otherlibs/sites_locations/src/plugins/sites_locations_plugins.ml @@ -21,10 +21,15 @@ module Private_ = struct let init id paths ocamlpath () = if !initialized_id <> id then - let env_ocamlpath = - String.concat Sites_locations.Private_.path_sep (paths@[ocamlpath]) - in - Findlib.init ~env_ocamlpath () + let ocamlpath = String.split_on_char Sites_locations.Private_.path_sep.[0] ocamlpath in + let search_path = (paths@ocamlpath) in + if Lazy.force Sites_locations.Private_.relocatable then + Findlib.init_manually ~search_path ~install_dir:"" ~meta_dir:"" () + else + let env_ocamlpath = + String.concat Sites_locations.Private_.path_sep search_path + in + Findlib.init ~env_ocamlpath () module Make (X:sig val paths: string list val ocamlpath: string end) : S = struct include X diff --git a/otherlibs/sites_locations/src/sites_locations.ml b/otherlibs/sites_locations/src/sites_locations.ml index a1cb4ee826f..cf9f846cc1d 100644 --- a/otherlibs/sites_locations/src/sites_locations.ml +++ b/otherlibs/sites_locations/src/sites_locations.ml @@ -78,9 +78,31 @@ module Private_ = struct let get_dir ~package ~section = Hashtbl.find_all dirs (package,section) + let relocatable = lazy ( + match eval Sites_locations_data.relocatable_encoded with + | Some "y" -> true + | None | Some "n" -> false + | Some _ -> assert false (* absurd: only y/n are generated *) + ) + + let prefix = lazy ( + let path = Sys.executable_name in + let bin = Filename.dirname path in + let prefix = Filename.dirname bin in + prefix + ) + let relocate_if_needed path = + if Lazy.force relocatable then + Filename.concat (Lazy.force prefix) path + else + path + let site ~package ~section ~suffix ~encoded = let dirs = get_dir ~package ~section in - let dirs = match eval encoded with None -> dirs | Some d -> d::dirs in + let dirs = match eval encoded with + | None -> dirs + | Some d -> (relocate_if_needed d)::dirs + in List.rev_map (fun dir -> Filename.concat dir suffix) dirs [@@inline never] @@ -103,6 +125,11 @@ module Private_ = struct | None | Some "" -> env | Some x -> x::env in + let env = + if Lazy.force relocatable then + (Filename.concat (Lazy.force prefix) "lib")::env + else env + in String.concat path_sep env end diff --git a/otherlibs/sites_locations/src/sites_locations.mli b/otherlibs/sites_locations/src/sites_locations.mli index 7171ffe5e57..e79539fcbf4 100644 --- a/otherlibs/sites_locations/src/sites_locations.mli +++ b/otherlibs/sites_locations/src/sites_locations.mli @@ -28,6 +28,7 @@ module Private_ : sig val site : package:string -> section:Section.t -> suffix:string -> encoded:string -> Location.t list + val relocatable: bool Lazy.t val ocamlpath: string -> string val sourceroot: string -> string option diff --git a/otherlibs/sites_locations/src/sites_locations_data.mli b/otherlibs/sites_locations/src/sites_locations_data.mli new file mode 100644 index 00000000000..cc86d9dc170 --- /dev/null +++ b/otherlibs/sites_locations/src/sites_locations_data.mli @@ -0,0 +1 @@ +val relocatable_encoded : string diff --git a/otherlibs/sites_locations/test/run.t b/otherlibs/sites_locations/test/run.t index 8dd2dae81c8..8152b87c18b 100644 --- a/otherlibs/sites_locations/test/run.t +++ b/otherlibs/sites_locations/test/run.t @@ -90,6 +90,9 @@ Test embedding of sites locations information $ dune build +Test with a normal installation +-------------------------------- + $ dune install --prefix _install 2> /dev/null Once installed, we have the sites information: @@ -104,6 +107,44 @@ Once installed, we have the sites information: b: $TESTCASE_ROOT/_install/share/b/data run c: b_registered:true +Test with a relocatable installation +-------------------------------- + + $ dune install --prefix _install_relocatable --relocatable 2> /dev/null + +Hack because findlib wants to load all the packages even the one already linked + $ mkdir _install_relocatable/lib/threads + $ echo 'package "posix" ( )' > _install_relocatable/lib/threads/META + +Once installed, we have the sites information: + + $ _install_relocatable/bin/c + run a + a: $TESTCASE_ROOT/_install_relocatable/share/a/data + run c: a linked b_registered:false + no sourceroot + c: $TESTCASE_ROOT/_install_relocatable/share/c/data + run b + b: $TESTCASE_ROOT/_install_relocatable/share/b/data + run c: b_registered:true + +Test after moving a relocatable installation +-------------------------------- + + $ mv _install_relocatable _install_relocatable2 + +Once installed, we have the sites information: + + $ _install_relocatable2/bin/c + run a + a: $TESTCASE_ROOT/_install_relocatable2/share/a/data + run c: a linked b_registered:false + no sourceroot + c: $TESTCASE_ROOT/_install_relocatable2/share/c/data + run b + b: $TESTCASE_ROOT/_install_relocatable2/share/b/data + run c: b_registered:true + Test substitution when promoting -------------------------------- diff --git a/src/dune/artifact_substitution.ml b/src/dune/artifact_substitution.ml index 9340637a4f0..7a21ceb42b7 100644 --- a/src/dune/artifact_substitution.ml +++ b/src/dune/artifact_substitution.ml @@ -36,12 +36,14 @@ type t = | Vcs_describe of Path.Source.t | Location of Section.t * Package.Name.t | LocalPath of localpath + | Relocatable | Repeat of int * string type conf = { get_vcs:(Path.Source.t -> Vcs.t option); get_location:(Section.t -> Package.Name.t -> Path.t); get_localPath:(localpath -> Path.t option); + is_relocatable: Path.t option; } let to_dyn = function @@ -51,9 +53,17 @@ let to_dyn = function | LocalPath d -> let v = match d with | SourceRoot -> "SourceRoot" | InstallLib -> "InstallLib" in Dyn.Variant ("LocalPath",[Dyn.Variant(v,[])]) + | Relocatable -> + Dyn.Variant ("Relocatable",[]) | Repeat (n, s) -> Dyn.Variant ("Repeat", [ Int n; String s ]) let eval t ~conf = + let relocatable path = + (* return a relative path to the install directory in case of relocatable instead of absolute path *) + match conf.is_relocatable with + | None -> Path.to_absolute_filename path + | Some install -> Path.reach path ~from:install + in match t with | Repeat (n, s) -> Fiber.return (Array.make n s |> Array.to_list |> String.concat ~sep:"") @@ -62,13 +72,15 @@ let eval t ~conf = | None -> Fiber.return "" | Some vcs -> Vcs.describe vcs ) | Location (name,lib_name) -> - Fiber.return (Path.to_absolute_filename (conf.get_location name lib_name)) + Fiber.return (relocatable (conf.get_location name lib_name)) | LocalPath d -> Fiber.return (Option.value ~default:"" (let open Option.O in let+ dir = (conf.get_localPath d) in - Path.to_absolute_filename dir)) + relocatable dir)) + | Relocatable -> + Fiber.return (if Option.is_some conf.is_relocatable then "y" else "n") let encode_replacement ~len ~repl:s = let repl = sprintf "=%u:%s" (String.length s) s in @@ -98,6 +110,8 @@ let encode ?(min_len = 0) t = sprintf "localpath:sourceroot:" | LocalPath InstallLib -> sprintf "localpath:installlib:" + | Relocatable -> + sprintf "relocatable" | Repeat (n, s) -> sprintf "repeat:%d:%d:%s" n (String.length s) s ) in let len = @@ -168,6 +182,8 @@ let decode s = LocalPath SourceRoot | "localpath" :: "installlib" :: _ -> LocalPath InstallLib + | "relocatable" :: _ -> + Relocatable | "repeat" :: repeat :: rest -> Repeat (parse_int repeat, read_string_payload rest) | _ -> fail () diff --git a/src/dune/artifact_substitution.mli b/src/dune/artifact_substitution.mli index 8ef9ca2c426..84c4bdaf1c2 100644 --- a/src/dune/artifact_substitution.mli +++ b/src/dune/artifact_substitution.mli @@ -11,6 +11,7 @@ type t = | Vcs_describe of Path.Source.t | Location of Section.t * Package.Name.t | LocalPath of localpath + | Relocatable | Repeat of int * string (** [Repeat (n, s)] evaluates to [s] repeated [n] times. This substitution is used for unit tests. *) @@ -19,6 +20,8 @@ type conf = { get_vcs:(Path.Source.t -> Vcs.t option); get_location:(Section.t -> Package.Name.t -> Path.t); get_localPath:(localpath -> Path.t option); + is_relocatable: Path.t option + (** Initial prefix of installation when relocatable chosen *) } val to_dyn : t -> Dyn.t diff --git a/src/dune/build_system.ml b/src/dune/build_system.ml index d65ddf8a1ce..38f7266adc5 100644 --- a/src/dune/build_system.ml +++ b/src/dune/build_system.ml @@ -1660,6 +1660,7 @@ end = struct ~conf:{ get_vcs = File_tree.nearest_vcs; get_location; get_localPath; + is_relocatable = None; } ~chmod )) in diff --git a/src/dune/dune_file.ml b/src/dune/dune_file.ml index d47e2f33bdd..f6fabb4bdb2 100644 --- a/src/dune/dune_file.ml +++ b/src/dune/dune_file.ml @@ -2074,6 +2074,7 @@ module Generate_module = struct ; module_ : Module_name.t ; ocamlpath: bool ; sourceroot: bool + ; relocatable: bool ; sites : (Loc.t * Package.Name.t) list ; plugins : (Loc.t * (Package.Name.t * (Loc.t * Section.Site.t))) list } @@ -2084,12 +2085,13 @@ module Generate_module = struct and+ module_ = field "module" Module_name.decode and+ ocamlpath = field_b "ocamlpath" and+ sourceroot = field_b "sourceroot" + and+ relocatable = field_b "relocatable" and+ sites = field "sites" ~default:[] (repeat (located Package.Name.decode)) and+ plugins = field "plugins" ~default:[] (repeat (located (pair Package.Name.decode (located Section.Site.decode)))) in - { loc; module_; sourceroot; ocamlpath; sites; plugins }) + { loc; module_; sourceroot; ocamlpath; relocatable; sites; plugins }) end type Stanza.t += diff --git a/src/dune/dune_file.mli b/src/dune/dune_file.mli index 81e52f3cde0..9f5d093a86b 100644 --- a/src/dune/dune_file.mli +++ b/src/dune/dune_file.mli @@ -441,6 +441,7 @@ module Generate_module : sig ; module_ : Module_name.t ; ocamlpath: bool ; sourceroot: bool + ; relocatable: bool ; sites : (Loc.t * Package.Name.t) list ; plugins : (Loc.t * (Package.Name.t * (Loc.t * Section.Site.t))) list } diff --git a/src/dune/generate_module_rules.ml b/src/dune/generate_module_rules.ml index 693af81a8f7..958ac56e0a4 100644 --- a/src/dune/generate_module_rules.ml +++ b/src/dune/generate_module_rules.ml @@ -9,6 +9,9 @@ let sourceroot_code buf = pr buf "let sourceroot = Sites_locations.Private_.sourceroot %S" (Artifact_substitution.encode ~min_len:max_path_length (LocalPath SourceRoot)) +let relocatable_code buf = + pr buf "let relocatable = Lazy.force Sites_locations.Private_.relocatable" + let ocamlpath_code buf = pr buf "let ocamlpath = Sites_locations.Private_.ocamlpath %S" (Artifact_substitution.encode ~min_len:max_path_length (LocalPath InstallLib)) @@ -59,6 +62,7 @@ let plugins_code sctx buf pkg sites = let setup_rules sctx ~dir (def:Dune_file.Generate_module.t) = let buf = Buffer.create 1024 in if def.sourceroot then sourceroot_code buf; + if def.relocatable then relocatable_code buf; if def.ocamlpath || List.is_non_empty def.plugins then ocamlpath_code buf; let sites = List.sort_uniq diff --git a/src/dune/lib_info.ml b/src/dune/lib_info.ml index 5de124126dd..046b6d661b7 100644 --- a/src/dune/lib_info.ml +++ b/src/dune/lib_info.ml @@ -102,10 +102,34 @@ module Special_builtin_support = struct ] end + module Sites_locations = struct + type t = + { data_module : string } + + let to_dyn { data_module } = + let open Dyn.Encoder in + record + [ ("data_module", string data_module) + ] + + let decode = + let open Dune_lang.Decoder in + fields + (let+ data_module = field "data_module" string in + { data_module }) + + let encode { data_module } = + let open Dune_lang.Encoder in + record_fields + [ field "data_module" string data_module + ] + end + type t = | Findlib_dynload | Build_info of Build_info.t | Configurator of Configurator.t + | Sites_locations of Sites_locations.t let to_dyn x = let open Dyn.Encoder in @@ -113,6 +137,7 @@ module Special_builtin_support = struct | Findlib_dynload -> constr "Findlib_dynload" [] | Build_info info -> constr "Build_info" [ Build_info.to_dyn info ] | Configurator info -> constr "Configurator" [ Configurator.to_dyn info ] + | Sites_locations info -> constr "Sites_locations" [ Sites_locations.to_dyn info ] let decode = let open Dune_lang.Decoder in @@ -126,15 +151,22 @@ module Special_builtin_support = struct , let+ () = Dune_lang.Syntax.since Stanza.syntax (2, 3) and+ info = Configurator.decode in Configurator info ) + ; ("sites_locations" + (* , let+ () = Dune_lang.Syntax.since Stanza.syntax (2, 4) *) + ,let+ info = Sites_locations.decode in + Sites_locations info) ] let encode t = match t with - | Findlib_dynload -> Dune_lang.atom "findlib_dynload" + | Findlib_dynload -> + Dune_lang.atom "findlib_dynload" | Build_info x -> Dune_lang.List (Dune_lang.atom "build_info" :: Build_info.encode x) | Configurator x -> Dune_lang.List (Dune_lang.atom "configurator" :: Configurator.encode x) + | Sites_locations x -> + Dune_lang.List (Dune_lang.atom "sites_locations" :: Sites_locations.encode x) end module Status = struct diff --git a/src/dune/lib_info.mli b/src/dune/lib_info.mli index 659c9324e5c..5f8b63afb8b 100644 --- a/src/dune/lib_info.mli +++ b/src/dune/lib_info.mli @@ -50,10 +50,16 @@ module Special_builtin_support : sig type t = { api_version : api_version } end + module Sites_locations : sig + type t = + { data_module : string } + end + type t = | Findlib_dynload | Build_info of Build_info.t | Configurator of Configurator.t + | Sites_locations of Sites_locations.t include Dune_lang.Conv.S with type t := t end diff --git a/src/dune/link_time_code_gen.ml b/src/dune/link_time_code_gen.ml index ac860e3fd5f..ac90eff1991 100644 --- a/src/dune/link_time_code_gen.ml +++ b/src/dune/link_time_code_gen.ml @@ -169,6 +169,14 @@ let build_info_code cctx ~libs ~api_version = pr buf "%S, %s" (Lib_name.to_string name) v); Buffer.contents buf + +let sites_locations_code () = + let buf = Buffer.create 1024 in + pr buf "let relocatable_encoded = %S" + (Artifact_substitution.encode ~min_len:1 Relocatable); + Buffer.contents buf + + let handle_special_libs cctx = let open Result.O in let+ all_libs = CC.requires_link cctx in @@ -229,6 +237,20 @@ let handle_special_libs cctx = | Configurator _ -> process_libs libs ~to_link_rev:(LM.Lib lib :: to_link_rev) - ~force_linkall ) ) + ~force_linkall + | Sites_locations { data_module } -> + let module_ = + generate_and_compile_module cctx ~name:data_module ~lib + ~code: + (Build.return + (sites_locations_code ())) + ~requires:(Ok [ lib ]) + ~precompiled_cmi:true + in + process_libs libs + ~to_link_rev:(LM.Lib lib :: Module (obj_dir, module_) :: to_link_rev) + ~force_linkall + + )) in process_libs all_libs ~to_link_rev:[] ~force_linkall:false diff --git a/test/unit-tests/artifact_substitution/artifact_substitution.ml b/test/unit-tests/artifact_substitution/artifact_substitution.ml index f5992fb8e60..a8d54f01a66 100644 --- a/test/unit-tests/artifact_substitution/artifact_substitution.ml +++ b/test/unit-tests/artifact_substitution/artifact_substitution.ml @@ -159,6 +159,7 @@ let test input = get_vcs=(fun _ -> None); get_location=(fun _ _ -> Path.root); get_localPath=(fun _ -> None); + is_relocatable=None; } ~input ~output); let result = Buffer.contents buf in