Experimental portable lockdirs

Adds a feature flag for enabling portable lockdirs. This is a proof of
concept implementation of portable lockdirs where the entire solver runs
for each of a set of platforms (combinations of architecture, OS, and in
some cases the OS distribution) which most people are expected to use.
This can easily be extended in the future to add more platforms or to
allow projects to specify more platforms.

To make lockdirs portable, the build/install commands and dependencies
of each package are transformed into match statements, where the
appropriate value for each platform is enumerated. At solve-time, the
solver runs once for each platform, populating these fields. At
build-time, the command/dependencies appropriate for the current
platform are used.

When the feature flag is not enabled dune's behaviour is unchanged.

Signed-off-by: Stephen Sherratt <[email protected]>

bin/lock_dev_tool.ml

@@ -82,6 +82,7 @@ let solve ~dev_tool ~local_packages =
        ~version_preference:None
        ~lock_dirs:[ lock_dir ]
        ~print_perf_stats:false
+       ~portable_lock_dir:false
 ;;
 
 let compiler_package_name = Package_name.of_string "ocaml"

bin/pkg/lock.ml

@@ -1,3 +1,4 @@
+open Dune_config
 open Import
 open Pkg_common
 module Package_version = Dune_pkg.Package_version
@@ -66,11 +67,75 @@ let resolve_project_pins project_pins =
   Pin_stanza.resolve project_pins ~scan_project
 ;;
 
+let solve_multiple_envs
+      base_solver_env
+      version_preference
+      repos
+      ~pins
+      ~local_packages
+      ~constraints
+  =
+  let open Fiber.O in
+  let solve_for_env env =
+    Dune_pkg.Opam_solver.solve_lock_dir
+      env
+      version_preference
+      repos
+      ~pins
+      ~local_packages
+      ~constraints
+  in
+  let portable_solver_env =
+    (* TODO: make sure nothing system-specific sneaks into the environment here *)
+    Dune_pkg.Solver_env.unset_multi
+      base_solver_env
+      Dune_lang.Package_variable_name.platform_specific
+  in
+  let+ results =
+    Fiber.parallel_map Dune_pkg.Solver_env.popular_platform_envs ~f:(fun platform_env ->
+      let solver_env = Dune_pkg.Solver_env.extend portable_solver_env platform_env in
+      solve_for_env solver_env)
+  in
+  let results, errors =
+    List.partition_map results ~f:(function
+      | Ok result -> Left result
+      | Error (`Diagnostic_message message) -> Right message)
+  in
+  match results with
+  | [] -> Error errors
+  | x :: xs ->
+    Ok (List.fold_left xs ~init:x ~f:Dune_pkg.Opam_solver.Solver_result.merge, errors)
+;;
+
+let solve_single_env
+      solver_env
+      version_preference
+      repos
+      ~pins
+      ~local_packages
+      ~constraints
+  =
+  let open Fiber.O in
+  let+ result =
+    Dune_pkg.Opam_solver.solve_lock_dir
+      solver_env
+      version_preference
+      repos
+      ~pins
+      ~local_packages
+      ~constraints
+  in
+  match result with
+  | Ok result -> Ok (result, [])
+  | Error (`Diagnostic_message message) -> Error [ message ]
+;;
+
 let solve_lock_dir
       workspace
       ~local_packages
       ~project_pins
       ~print_perf_stats
+      ~portable_lock_dir
       version_preference
       solver_env_from_current_system
       lock_dir_path
@@ -109,7 +174,8 @@ let solve_lock_dir
   let* pins = resolve_project_pins project_pins in
   let time_solve_start = Unix.gettimeofday () in
   progress_state := Some Progress_indicator.Per_lockdir.State.Solving;
-  Dune_pkg.Opam_solver.solve_lock_dir
+  let solve = if portable_lock_dir then solve_multiple_envs else solve_single_env in
+  solve
     solver_env
     (Pkg_common.Version_preference.choose
        ~from_arg:version_preference
@@ -121,8 +187,11 @@ let solve_lock_dir
       (Package_name.Map.map local_packages ~f:Dune_pkg.Local_package.for_solver)
     ~constraints:(constraints_of_workspace workspace ~lock_dir_path)
   >>= function
-  | Error (`Diagnostic_message message) -> Fiber.return (Error (lock_dir_path, message))
-  | Ok { lock_dir; files; pinned_packages; num_expanded_packages } ->
+  | Error messages -> Fiber.return (Error (lock_dir_path, messages))
+  | Ok ({ lock_dir; files; pinned_packages; num_expanded_packages }, _errors) ->
+    (* TODO: Users might want to know if no solution was found on certain
+       platforms. Give the option to print the solver errors, even if a
+       solution was found on some platforms. *)
     let time_end = Unix.gettimeofday () in
     let maybe_perf_stats =
       if print_perf_stats
@@ -149,7 +218,13 @@ let solve_lock_dir
     in
     progress_state := None;
     let+ lock_dir = Lock_dir.compute_missing_checksums ~pinned_packages lock_dir in
-    Ok (Lock_dir.Write_disk.prepare ~lock_dir_path ~files lock_dir, summary_message)
+    Ok
+      ( Lock_dir.Write_disk.prepare
+          ~portable:portable_lock_dir
+          ~lock_dir_path
+          ~files
+          lock_dir
+      , summary_message )
 ;;
 
 let solve
@@ -160,6 +235,7 @@ let solve
       ~version_preference
       ~lock_dirs
       ~print_perf_stats
+      ~portable_lock_dir
   =
   let open Fiber.O in
   (* a list of thunks that will perform all the file IO side
@@ -182,6 +258,7 @@ let solve
                 ~local_packages
                 ~project_pins
                 ~print_perf_stats
+                ~portable_lock_dir
                 version_preference
                 solver_env_from_current_system
                 lockdir_path
@@ -196,9 +273,9 @@ let solve
   | Error errors ->
     User_error.raise
       ([ Pp.text "Unable to solve dependencies for the following lock directories:" ]
-       @ List.concat_map errors ~f:(fun (path, message) ->
+       @ List.concat_map errors ~f:(fun (path, messages) ->
          [ Pp.textf "Lock directory %s:" (Path.Source.to_string_maybe_quoted path)
-         ; Pp.hovbox message
+         ; Pp.hovbox (Pp.concat ~sep:Pp.newline messages)
          ]))
   | Ok write_disks_with_summaries ->
     let write_disk_list, summary_messages = List.split write_disks_with_summaries in
@@ -214,7 +291,7 @@ let project_pins =
     Pin_stanza.DB.combine_exn acc (Dune_project.pins project))
 ;;
 
-let lock ~version_preference ~lock_dirs_arg ~print_perf_stats =
+let lock ~version_preference ~lock_dirs_arg ~print_perf_stats ~portable_lock_dir =
   let open Fiber.O in
   let* solver_env_from_current_system =
     Dune_pkg.Sys_poll.make ~path:(Env_path.path Stdune.Env.initial)
@@ -240,6 +317,7 @@ let lock ~version_preference ~lock_dirs_arg ~print_perf_stats =
     ~version_preference
     ~lock_dirs
     ~print_perf_stats
+    ~portable_lock_dir
 ;;
 
 let term =
@@ -250,7 +328,12 @@ let term =
   let builder = Common.Builder.forbid_builds builder in
   let common, config = Common.init builder in
   Scheduler.go ~common ~config (fun () ->
-    lock ~version_preference ~lock_dirs_arg ~print_perf_stats)
+    let portable_lock_dir =
+      match Config.get Dune_rules.Compile_time.portable_lock_dir with
+      | `Enabled -> true
+      | `Disabled -> false
+    in
+    lock ~version_preference ~lock_dirs_arg ~print_perf_stats ~portable_lock_dir)
 ;;
 
 let info =

bin/pkg/lock.mli

@@ -8,6 +8,7 @@ val solve
   -> version_preference:Dune_pkg.Version_preference.t option
   -> lock_dirs:Path.Source.t list
   -> print_perf_stats:bool
+  -> portable_lock_dir:bool
   -> unit Fiber.t
 
 (** Command to create lock directory *)

boot/configure.ml

@@ -18,7 +18,11 @@ let out =
 ;;
 
 let default_toggles : (string * [ `Disabled | `Enabled ]) list =
-  [ "toolchains", `Enabled; "pkg_build_progress", `Disabled; "lock_dev_tool", `Disabled ]
+  [ "toolchains", `Enabled
+  ; "pkg_build_progress", `Disabled
+  ; "lock_dev_tool", `Disabled
+  ; "portable_lock_dir", `Disabled
+  ]
 ;;
 
 let toggles = ref default_toggles
@@ -101,6 +105,10 @@ let () =
       , " Enable ocamlformat dev-tool, allows 'dune fmt' to build ocamlformat and use \
          it, independently from the project depenedencies .\n\
         \      This flag is experimental and shouldn't be relied on by packagers." )
+    ; ( "--portable-lock-dir"
+      , toggle "portable_lock_dir"
+      , "Generate portable lock dirs. If this feature is disabled then lock dirs will be \
+         specialized to the machine where they are generated." )
     ]
   in
   let anon s = bad "Don't know what to do with %s" s in

boot/libs.ml

@@ -1,4 +1,4 @@
-let external_libraries = [ "unix"; "threads" ]
+let external_libraries = [ "threads.posix" ]
 
 let local_libraries =
   [ ("otherlibs/ordering", Some "Ordering", false, None)

src/dune_lang/package_variable_name.ml

@@ -53,6 +53,10 @@ let post = of_string "post"
 let one_of t xs = List.mem xs ~equal t
 let dev = of_string "dev"
 
+let platform_specific =
+  Set.of_list [ arch; os; os_version; os_distribution; os_family; sys_ocaml_version ]
+;;
+
 module Project = struct
   let encode name = Dune_sexp.Encoder.string (":" ^ to_string name)
 

src/dune_lang/package_variable_name.mli

@@ -32,6 +32,10 @@ val build : t
 val dev : t
 val one_of : t -> t list -> bool
 
+(** The set of variable names whose values are expected to differ depending on
+    the current platform. *)
+val platform_specific : Set.t
+
 module Project : sig
   val encode : t Dune_sexp.Encoder.t
   val decode : t Dune_sexp.Decoder.t

src/dune_pkg/file_entry.ml

@@ -4,7 +4,28 @@ type source =
   | Path of Path.t
   | Content of string
 
+let source_equal a b =
+  match a, b with
+  | Path a, Path b -> Path.equal a b
+  | Content a, Content b -> String.equal a b
+  | Path _, Content _ | Content _, Path _ -> false
+;;
+
+let source_to_dyn = function
+  | Path path -> Dyn.variant "Path" [ Path.to_dyn path ]
+  | Content content -> Dyn.variant "Content" [ Dyn.string content ]
+;;
+
 type t =
   { original : source
   ; local_file : Path.Local.t
   }
+
+let equal { original; local_file } t =
+  source_equal original t.original && Path.Local.equal local_file t.local_file
+;;
+
+let to_dyn { original; local_file } =
+  Dyn.record
+    [ "original", source_to_dyn original; "local_file", Path.Local.to_dyn local_file ]
+;;

src/dune_pkg/file_entry.mli

@@ -8,3 +8,6 @@ type t =
   { original : source
   ; local_file : Path.Local.t
   }
+
+val equal : t -> t -> bool
+val to_dyn : t -> Dyn.t