diff --git a/src/client/opamAdminCheck.ml b/src/client/opamAdminCheck.ml index ce2b6fcb25e..c18ccce1636 100644 --- a/src/client/opamAdminCheck.ml +++ b/src/client/opamAdminCheck.ml @@ -62,11 +62,11 @@ let get_universe ~with_test ~with_doc ~dev opams = u_reinstall = OpamPackage.Set.empty; } -let installability_check univ = +let installability_check ~task_pool univ = let packages = univ.u_packages in let graph = OpamCudf.Graph.of_universe @@ - OpamSolver.load_cudf_universe + OpamSolver.load_cudf_universe ~task_pool ~depopts:false ~build:true ~post:true univ packages () in let filter_roots g packages = @@ -78,7 +78,7 @@ let installability_check univ = else acc) g OpamPackage.Set.empty in - let installable = OpamSolver.installable univ in + let installable = OpamSolver.installable ~task_pool univ in let uninstallable = packages -- installable in let unav_roots = filter_roots graph uninstallable in unav_roots, uninstallable @@ -98,9 +98,9 @@ let formula_of_pkglist packages = function (OpamPackage.versions_of_packages (OpamPackage.Set.of_list nvs))) -let cycle_check univ = +let cycle_check ~task_pool univ = let cudf_univ = - OpamSolver.load_cudf_universe + OpamSolver.load_cudf_universe ~task_pool ~depopts:true ~build:true ~post:false univ univ.u_packages () in let graph = @@ -403,7 +403,7 @@ let get_obsolete univ opams = if is_obsolete then acc ++ pkgs else acc) aggregates PkgSet.empty -let check ~quiet ~installability ~cycles ~obsolete ~ignore_test repo_root = +let check ~task_pool ~quiet ~installability ~cycles ~obsolete ~ignore_test repo_root = let pkg_prefixes = OpamRepository.packages_with_prefixes repo_root in let opams = OpamPackage.Map.fold (fun nv prefix acc -> @@ -431,7 +431,7 @@ let check ~quiet ~installability ~cycles ~obsolete ~ignore_test repo_root = if not quiet then OpamConsole.msg "Checking installability of every package. This may \ take a few minutes...\n"; - installability_check univ + installability_check ~task_pool univ ) in if not quiet then @@ -449,7 +449,7 @@ let check ~quiet ~installability ~cycles ~obsolete ~ignore_test repo_root = (* Cyclic dependency checks *) let cycle_packages, cycle_formulas = if not cycles then PkgSet.empty, [] - else cycle_check univ + else cycle_check ~task_pool univ in if not quiet && cycle_formulas <> [] then (OpamConsole.error "Dependency cycles detected:"; diff --git a/src/client/opamAdminCheck.mli b/src/client/opamAdminCheck.mli index 603a852fcb7..88f0babb0e5 100644 --- a/src/client/opamAdminCheck.mli +++ b/src/client/opamAdminCheck.mli @@ -13,17 +13,18 @@ open OpamTypes (** Analyses a given package universe, and returns [uninstallable_roots,uninstallable]. The first is a subset of the second, where internal dependents have been removed. *) -val installability_check: universe -> package_set * package_set +val installability_check: task_pool:Domainslib.Task.pool -> universe -> package_set * package_set (** Analyses a universe for dependency cycles. Returns the set of packages involved, and the cycles (reduced to formula lists) *) -val cycle_check: universe -> package_set * formula list list +val cycle_check: task_pool:Domainslib.Task.pool -> universe -> package_set * formula list list (** Runs checks on the repository at the given repository. Returns [all_packages], [uninstallable_roots], [uninstallable], [cycle_packages], [obsolete_packages]. If the corresponding option was disabled, the returned sets are empty. *) val check: + task_pool:Domainslib.Task.pool -> quiet:bool -> installability:bool -> cycles:bool -> obsolete:bool -> ignore_test:bool -> dirname -> package_set * package_set * package_set * package_set * package_set diff --git a/src/client/opamAdminCommand.ml b/src/client/opamAdminCommand.ml index baebc3778e3..7de432205cc 100644 --- a/src/client/opamAdminCommand.ml +++ b/src/client/opamAdminCommand.ml @@ -785,6 +785,7 @@ let check_command cli = let cmd global_options ignore_test print_short installability cycles obsolete () = OpamArg.apply_global_options cli global_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> let repo_root = checked_repo_root () in let installability, cycles, obsolete = if installability || cycles || obsolete @@ -793,7 +794,7 @@ let check_command cli = in let pkgs, unav_roots, uninstallable, cycle_packages, obsolete = OpamAdminCheck.check - ~quiet:print_short ~installability ~cycles ~obsolete ~ignore_test + ~quiet:print_short ~installability ~cycles ~obsolete ~ignore_test ~task_pool repo_root in let all_ok = @@ -803,27 +804,27 @@ let check_command cli = in let open OpamPackage.Set.Op in (if print_short then - OpamConsole.msg "%s\n" - (OpamStd.List.concat_map "\n" OpamPackage.to_string + OpamConsole.msg "%s\n" + (OpamStd.List.concat_map "\n" OpamPackage.to_string (OpamPackage.Set.elements - (uninstallable ++ cycle_packages ++ obsolete))) - else if all_ok then - OpamConsole.msg "No issues detected on this repository's %d packages\n" - (OpamPackage.Set.cardinal pkgs) - else - let pr set msg = - if OpamPackage.Set.is_empty set then "" - else Printf.sprintf "- %d %s\n" (OpamPackage.Set.cardinal set) msg - in - OpamConsole.msg "Summary: out of %d packages (%d distinct names)\n\ + (uninstallable ++ cycle_packages ++ obsolete))) + else if all_ok then + OpamConsole.msg "No issues detected on this repository's %d packages\n" + (OpamPackage.Set.cardinal pkgs) + else + let pr set msg = + if OpamPackage.Set.is_empty set then "" + else Printf.sprintf "- %d %s\n" (OpamPackage.Set.cardinal set) msg + in + OpamConsole.msg "Summary: out of %d packages (%d distinct names)\n\ %s%s%s%s\n" - (OpamPackage.Set.cardinal pkgs) - (OpamPackage.Name.Set.cardinal (OpamPackage.names_of_packages pkgs)) - (pr unav_roots "uninstallable roots") - (pr (uninstallable -- unav_roots) "uninstallable dependent packages") - (pr (cycle_packages -- uninstallable) + (OpamPackage.Set.cardinal pkgs) + (OpamPackage.Name.Set.cardinal (OpamPackage.names_of_packages pkgs)) + (pr unav_roots "uninstallable roots") + (pr (uninstallable -- unav_roots) "uninstallable dependent packages") + (pr (cycle_packages -- uninstallable) "packages part of dependency cycles") - (pr obsolete "obsolete packages")); + (pr obsolete "obsolete packages")); OpamStd.Sys.exit_because (if all_ok then `Success else `False) in OpamArg.mk_command ~cli OpamArg.cli_original command ~doc ~man @@ -898,7 +899,7 @@ let get_virtual_switch_state repo_root env = let singl x = OpamRepositoryName.Map.singleton repo.repo_name x in let repos_tmp = let t = Hashtbl.create 1 in - Hashtbl.add t repo.repo_name (lazy repo_root); t + Hashtbl.add t repo.repo_name (OpamLazy.create (fun () -> repo_root)); t in let rt = { repos_global = gt; @@ -912,7 +913,7 @@ let get_virtual_switch_state repo_root env = {gt with global_variables = OpamVariable.Map.of_list @@ List.map (fun (var, value) -> - var, (lazy (Some value), "Manually defined")) + var, (OpamLazy.create (fun () -> (Some value)), "Manually defined")) env } in OpamSwitchState.load_virtual @@ -944,6 +945,7 @@ let list_command cli = global_options package_selection disjunction state_selection package_listing env packages () = OpamArg.apply_global_options cli global_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> let format = let force_all_versions = match packages with @@ -954,7 +956,7 @@ let list_command cli = | Some (n, _v) -> n in (try ignore (OpamPackage.Name.of_string nameglob); true - with Failure _ -> false) + with Failure _ -> false) | _ -> false in package_listing ~force_all_versions @@ -975,9 +977,9 @@ let list_command cli = OpamConsole.msg "# Packages matching: %s\n" (OpamListCommand.string_of_formula filter); let results = - OpamListCommand.filter ~base:st.packages st filter + OpamListCommand.filter ~task_pool ~base:st.packages st filter in - OpamListCommand.display st format results + OpamListCommand.display ~task_pool st format results in OpamArg.mk_command ~cli OpamArg.cli_original command ~doc ~man Term.(const cmd $ global_options cli $ OpamArg.package_selection cli $ @@ -1011,6 +1013,7 @@ let filter_command cli = global_options package_selection disjunction state_selection env remove dryrun packages () = OpamArg.apply_global_options cli global_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> let repo_root = OpamFilename.cwd () in let pattern_selector = OpamListCommand.pattern_selector packages in let join = @@ -1021,15 +1024,15 @@ let filter_command cli = Atom state_selection; join (pattern_selector :: - List.map (fun x -> Atom x) package_selection) + List.map (fun x -> Atom x) package_selection) ] in let st = get_virtual_switch_state repo_root env in - let packages = OpamListCommand.filter ~base:st.packages st filter in + let packages = OpamListCommand.filter ~task_pool ~base:st.packages st filter in if OpamPackage.Set.is_empty packages then if remove then (OpamConsole.warning "No packages match the selection criteria"; - OpamStd.Sys.exit_because `Success) + OpamStd.Sys.exit_because `Success) else OpamConsole.error_and_exit `Not_found "No packages match the selection criteria"; @@ -1038,17 +1041,17 @@ let filter_command cli = if remove then OpamConsole.formatted_msg "The following %d packages will be REMOVED from the repository (%d \ - packages will be kept):\n%s\n" + packages will be kept):\n%s\n" num_selected (num_total - num_selected) (OpamStd.List.concat_map " " OpamPackage.to_string - (OpamPackage.Set.elements packages)) + (OpamPackage.Set.elements packages)) else OpamConsole.formatted_msg "The following %d packages will be kept in the repository (%d packages \ - will be REMOVED):\n%s\n" + will be REMOVED):\n%s\n" num_selected (num_total - num_selected) (OpamStd.List.concat_map " " OpamPackage.to_string - (OpamPackage.Set.elements packages)); + (OpamPackage.Set.elements packages)); let packages = if remove then packages else OpamPackage.Set.Op.(st.packages -- packages) in @@ -1063,9 +1066,9 @@ let filter_command cli = OpamConsole.msg "rm -rf %s\n" (OpamFilename.Dir.to_string d) else (OpamFilename.cleandir d; - OpamFilename.rmdir_cleanup d)) + OpamFilename.rmdir_cleanup d)) pkg_prefixes - in +in OpamArg.mk_command ~cli OpamArg.cli_original command ~doc ~man Term.(const cmd $ global_options cli $ OpamArg.package_selection cli $ or_arg cli $ state_selection_arg cli $ env_arg cli $ remove_arg $ diff --git a/src/client/opamArg.ml b/src/client/opamArg.ml index b37db85f2cc..d66db8f4f12 100644 --- a/src/client/opamArg.ml +++ b/src/client/opamArg.ml @@ -500,12 +500,12 @@ let apply_global_options cli o = let some x = match x with None -> None | some -> Some some in let solver = if o.use_internal_solver then - Some (lazy (OpamCudfSolver.get_solver ~internal:true + Some (OpamLazy.create (fun () -> OpamCudfSolver.get_solver ~internal:true OpamCudfSolver.default_solver_selection)) else - o.external_solver >>| fun s -> lazy (OpamCudfSolver.solver_of_string s) + o.external_solver >>| fun s -> OpamLazy.create (fun () -> OpamCudfSolver.solver_of_string s) in - let solver_prefs = o.solver_preferences >>| fun p -> lazy (Some p) in + let solver_prefs = o.solver_preferences >>| fun p -> OpamLazy.create (fun () -> Some p) in let yes = OpamStd.Option.(map some o.yes) in init_opam_env_variabes cli; OpamClientConfig.opam_init @@ -658,14 +658,14 @@ let apply_build_options cli b = (); OpamStateConfig.update (* ?root: -- handled globally *) - ?jobs:(b.jobs >>| fun j -> lazy j) + ?jobs:(b.jobs >>| fun j -> OpamLazy.create (fun () -> j)) (* ?dl_jobs:int *) (* ?no_base_packages:(flag o.no_base_packages) -- handled globally *) ?build_test:(flag b.build_test) ?build_doc:(flag b.build_doc) ?dev_setup:(flag b.dev_setup) ?dryrun:(flag b.dryrun) - ?makecmd:(b.make >>| fun m -> lazy m) + ?makecmd:(b.make >>| fun m -> OpamLazy.create (fun () -> m)) ?ignore_constraints_on: (b.ignore_constraints_on >>| OpamPackage.Name.Set.of_list) diff --git a/src/client/opamAuxCommands.ml b/src/client/opamAuxCommands.ml index cbcc6851b5d..58168e1cdc4 100644 --- a/src/client/opamAuxCommands.ml +++ b/src/client/opamAuxCommands.ml @@ -380,11 +380,11 @@ let simulate_local_pinnings ?quiet ?(for_view=false) st to_pin = OpamPackage.Map.union (fun _ o -> o) st.opams local_opams; packages = OpamPackage.Set.union st.packages local_packages; - available_packages = lazy ( + available_packages = OpamLazy.create (fun () -> OpamPackage.Set.union (OpamPackage.Set.filter (fun nv -> not (OpamPackage.Name.Set.mem nv.name local_names)) - (Lazy.force st.available_packages)) + (OpamLazy.force st.available_packages)) (OpamSwitchState.compute_available_packages st.switch_global st.switch st.switch_config ~pinned ~opams:local_opams) @@ -520,7 +520,7 @@ let check_and_revert_sandboxing root config = | None -> OpamStd.Option.(Op.(of_Not_found (OpamStd.List.assoc OpamVariable.equal fv) - OpamSysPoll.variables >>= Lazy.force)) + OpamSysPoll.variables >>= OpamLazy.force)) in match OpamFilter.commands env sdbx_wrappers with | [] -> config diff --git a/src/client/opamCliMain.ml b/src/client/opamCliMain.ml index 642cc0fbf30..07b0baf33c8 100644 --- a/src/client/opamCliMain.ml +++ b/src/client/opamCliMain.ml @@ -253,7 +253,7 @@ let check_and_run_external_commands () = if OpamPackage.Set.is_empty plugins then plugins else - OpamPackage.Set.inter plugins (Lazy.force st.available_packages) + OpamPackage.Set.inter plugins (OpamLazy.force st.available_packages) in let installed = OpamPackage.Set.inter plugins st.installed in if OpamPackage.Set.is_empty candidates then (cli, argv) @@ -299,14 +299,15 @@ let check_and_run_external_commands () = OpamSolverConfig.init (); OpamClientConfig.init (); OpamSwitchState.with_ `Lock_write gt (fun st -> - OpamSwitchState.drop @@ ( - if cmd = None then - OpamClient.install st [OpamSolution.eq_atom_of_package nv] - else if root_upgraded then - OpamClient.reinstall st [OpamSolution.eq_atom_of_package nv] - else - OpamClient.upgrade st ~all:false [OpamSolution.eq_atom_of_package nv]) - ); + OpamMulticore.run_with_task_pool @@ fun task_pool -> + OpamSwitchState.drop @@ ( + if cmd = None then + OpamClient.install ~task_pool st [OpamSolution.eq_atom_of_package nv] + else if root_upgraded then + OpamClient.reinstall ~task_pool st [OpamSolution.eq_atom_of_package nv] + else + OpamClient.upgrade ~task_pool st ~all:false [OpamSolution.eq_atom_of_package nv]) + ); match OpamSystem.resolve_command ~env command with | None -> OpamConsole.error_and_exit `Package_operation_error @@ -439,6 +440,7 @@ let rec main_catch_all f = exit exit_code let run () = + (*Dose_doseparse.StdDebug.all_enabled ();*) OpamStd.Option.iter OpamVersion.set_git OpamGitVersion.version; OpamSystem.init (); OpamArg.preinit_opam_env_variables (); diff --git a/src/client/opamClient.ml b/src/client/opamClient.ml index 3da136d4d83..8e33f4d623e 100644 --- a/src/client/opamClient.ml +++ b/src/client/opamClient.ml @@ -65,7 +65,7 @@ let update_dev_packages_t ?autolock ?(only_installed=false) atoms t = let compute_upgrade_t ?(strict_upgrade=true) ?(auto_install=false) ?(only_installed=false) - ~all ~formula atoms t = + ~task_pool ~all ~formula atoms t = let packages = OpamFormula.packages_of_atoms t.packages atoms in let names = OpamPackage.Name.Set.of_list (List.rev_map fst atoms) in let atoms = @@ -77,11 +77,11 @@ let compute_upgrade_t let strict_upgrade_atom = (n, Some (`Gt, nv.version)) in if not (OpamSwitchState.is_dev_package t nv) && not (OpamPackage.has_name t.pinned n) && - not (OpamPackage.Set.mem nv (Lazy.force t.reinstall)) && + not (OpamPackage.Set.mem nv (OpamLazy.force t.reinstall)) && OpamPackage.Set.exists (not @* OpamSwitchState.avoid_version t) (OpamFormula.packages_of_atoms - (Lazy.force t.available_packages) + (OpamLazy.force t.available_packages) [strict_upgrade_atom]) then strict_upgrade_atom else atom @@ -110,15 +110,15 @@ let compute_upgrade_t List.partition (fun (n,_) -> match OpamPackage.package_of_name_opt t.installed n with | None -> true - | Some nv -> not (OpamPackage.Set.mem nv (Lazy.force t.available_packages))) + | Some nv -> not (OpamPackage.Set.mem nv (OpamLazy.force t.available_packages))) atoms in let criteria = if to_install = [] then `Upgrade else `Default in if all then names, - OpamSolution.resolve t Upgrade + OpamSolution.resolve ~task_pool t Upgrade ~requested:packages - ~reinstall:(Lazy.force t.reinstall) + ~reinstall:(OpamLazy.force t.reinstall) (OpamSolver.request ~install:to_install ~upgrade:to_upgrade @@ -127,7 +127,7 @@ let compute_upgrade_t ~criteria ()) else names, - OpamSolution.resolve t Upgrade + OpamSolution.resolve ~task_pool t Upgrade ~requested:packages (OpamSolver.request ~install:to_install @@ -143,13 +143,13 @@ let print_requested requested formula = let upgrade_t ?strict_upgrade ?auto_install ?ask ?(check=false) ?(terse=false) - ?only_installed ~all atoms ?(formula=OpamFormula.Empty) t + ?only_installed ~task_pool ~all atoms ?(formula=OpamFormula.Empty) t = log "UPGRADE %a" (slog @@ function [] -> "" | a -> OpamFormula.string_of_atoms a) atoms; match - compute_upgrade_t ?strict_upgrade ?auto_install ?only_installed ~all + compute_upgrade_t ?strict_upgrade ?auto_install ?only_installed ~task_pool ~all ~formula atoms t with | requested, Conflicts cs -> @@ -192,7 +192,7 @@ let upgrade_t else let packages = OpamPackage.packages_of_names t.packages requested in let t, result = - OpamSolution.apply ?ask t ~requested:packages + OpamSolution.apply ?ask ~task_pool t ~requested:packages ~print_requested:(print_requested requested formula) solution in @@ -213,8 +213,8 @@ let upgrade_t OpamConsole.msg "No package build needed.\n" else (let hdmsg = "Everything as up-to-date as possible" in - let unav = notuptodate -- Lazy.force t.available_packages in - let unopt = notuptodate %% Lazy.force t.available_packages in + let unav = notuptodate -- OpamLazy.force t.available_packages in + let unopt = notuptodate %% OpamLazy.force t.available_packages in let base = OpamPackage.packages_of_names unopt (OpamPackage.names_of_packages t.compiler_packages) @@ -339,18 +339,18 @@ let upgrade_t OpamSolution.check_solution t (Success result); t -let upgrade t ?formula ?check ?only_installed ~all names = +let upgrade ~task_pool t ?formula ?check ?only_installed ~all names = let atoms = OpamSolution.sanitize_atom_list t names in let t = update_dev_packages_t ~autolock:true ?only_installed atoms t in - upgrade_t ?check ~strict_upgrade:(not all) ?only_installed ~all + upgrade_t ?check ~strict_upgrade:(not all) ?only_installed ~task_pool ~all atoms ?formula t -let fixup ?(formula=OpamFormula.Empty) t = +let fixup ?(formula=OpamFormula.Empty) ~task_pool t = (* @LG reimplement as an alias for 'opam upgrade --criteria=fixup --best-effort --update-invariant *) log "FIXUP"; let resolve pkgs = pkgs, - OpamSolution.resolve t Upgrade + OpamSolution.resolve ~task_pool t Upgrade ~requested:pkgs (OpamSolver.request ~install:(OpamSolution.atoms_of_packages pkgs) @@ -372,7 +372,7 @@ let fixup ?(formula=OpamFormula.Empty) t = let s = log "fixup-1/ keep installed packages with orphaned versions and roots"; resolve (t.installed_roots %% t.installed - %% Lazy.force t.available_packages) + %% OpamLazy.force t.available_packages) in if is_success s then s else let s = @@ -398,7 +398,7 @@ let fixup ?(formula=OpamFormula.Empty) t = print_requested (OpamPackage.names_of_packages requested) formula in let t, res = - OpamSolution.apply ~ask:true t + OpamSolution.apply ~task_pool ~ask:true t ~requested ~print_requested solution in @@ -590,7 +590,7 @@ let init_checks ?(hard_fail_exn=true) init_config = let vs = OpamVariable.Full.variable v in OpamStd.Option.(Op.(of_Not_found (OpamStd.List.assoc OpamVariable.equal vs) - OpamSysPoll.variables >>= Lazy.force)) + OpamSysPoll.variables >>= OpamLazy.force)) in let filter_tools = OpamStd.List.filter_map (fun (cmd,str,oflt) -> @@ -743,7 +743,7 @@ let windows_checks ?cygwin_setup ?git_location config = end; let vars = OpamFile.Config.global_variables config in let env = - List.map (fun (v, c, s) -> v, (lazy (Some c), s)) vars + List.map (fun (v, c, s) -> v, (OpamLazy.create (fun () -> (Some c)), s)) vars |> OpamVariable.Map.of_list in (* Git handling *) @@ -1057,7 +1057,7 @@ let reinit ?(init_config=OpamInitDefaults.init_config()) ~interactive let vs = OpamVariable.Full.variable v in OpamStd.Option.(Op.(of_Not_found (OpamStd.List.assoc OpamVariable.equal vs) - OpamSysPoll.variables >>= Lazy.force)) + OpamSysPoll.variables >>= OpamLazy.force)) in OpamStd.List.filter_map (fun ((nam,scr),oflt) -> match oflt with | None -> Some (nam,scr) @@ -1084,6 +1084,7 @@ let reinit ?(init_config=OpamInitDefaults.init_config()) ~interactive OpamRepositoryState.drop rt let init + ~task_pool ~init_config ~interactive ?repo ?(bypass_checks=false) ?dot_profile ?update_config ?env_hook ?(completion=true) @@ -1139,7 +1140,7 @@ let init let vs = OpamVariable.Full.variable v in OpamStd.Option.(Op.(of_Not_found (OpamStd.List.assoc OpamVariable.equal vs) - OpamSysPoll.variables >>= Lazy.force)) + OpamSysPoll.variables >>= OpamLazy.force)) in let scripts = OpamFile.InitConfig.init_scripts init_config in OpamStd.List.filter_map (fun ((nam,scr),oflt) -> match oflt with @@ -1187,12 +1188,12 @@ let init in let univ = OpamSwitchState.universe virt_st - ~requested:OpamPackage.Set.empty Query + ~requested:OpamPackage.Set.empty ~task_pool Query in let univ = { univ with u_invariant = invariant } in let default_compiler = OpamStd.List.find_opt - (OpamSolver.atom_coinstallability_check univ) + (OpamSolver.atom_coinstallability_check ~task_pool univ) alternatives |> OpamStd.Option.default [] in @@ -1214,7 +1215,7 @@ let init gt, rt, default_compiler let check_installed ~build ~post t atoms = - let available = (Lazy.force t.available_packages) in + let available = (OpamLazy.force t.available_packages) in let uninstalled = OpamPackage.Set.Op.(available -- t.installed) in let pkgs = OpamPackage.to_map @@ -1269,7 +1270,7 @@ let check_installed ~build ~post t atoms = map ) pkgs OpamPackage.Map.empty -let assume_built_restrictions ?available_packages t atoms = +let assume_built_restrictions ?available_packages ~task_pool t atoms = let missing = check_installed ~build:false ~post:false t atoms in let atoms = if OpamPackage.Map.is_empty missing then atoms else @@ -1297,14 +1298,14 @@ let assume_built_restrictions ?available_packages t atoms = t.pinned in let installed_dependencies = - OpamSwitchState.dependencies ~build:false ~post:false + OpamSwitchState.dependencies ~task_pool ~build:false ~post:false ~depopts:false ~installed:true ~unavailable:false t pinned in let available_packages = match available_packages with | Some a -> a - | None -> Lazy.force t.available_packages + | None -> OpamLazy.force t.available_packages in let uninstalled_dependencies = (OpamPackage.Map.values missing @@ -1312,7 +1313,7 @@ let assume_built_restrictions ?available_packages t atoms = |> OpamPackage.packages_of_names available_packages) -- installed_dependencies in - let available_packages = lazy ( + let available_packages = OpamLazy.create (fun () -> (available_packages -- uninstalled_dependencies) ++ t.installed ++ pinned ) in let fixed_atoms = @@ -1340,11 +1341,11 @@ let filter_unpinned_locally t atoms f = None)) atoms -let install_t t ?ask ?(ignore_conflicts=false) ?(depext_only=false) +let install_t ~task_pool t ?ask ?(ignore_conflicts=false) ?(depext_only=false) ?(download_only=false) atoms ?(formula=OpamFormula.Empty) add_to_roots ~deps_only ~assume_built = log "INSTALL %a" (slog OpamFormula.string_of_atoms) atoms; - let available_packages = Lazy.force t.available_packages in + let available_packages = OpamLazy.force t.available_packages in let atoms = let compl = function @@ -1435,7 +1436,7 @@ let install_t t ?ask ?(ignore_conflicts=false) ?(depext_only=false) get_installed_atoms t atoms in let pkg_reinstall = if assume_built then OpamPackage.Set.of_list pkg_skip - else Lazy.force t.reinstall %% OpamPackage.Set.of_list pkg_skip + else OpamLazy.force t.reinstall %% OpamPackage.Set.of_list pkg_skip in (* Add the packages to the list of package roots and display a warning for already installed package roots. *) @@ -1502,7 +1503,7 @@ let install_t t ?ask ?(ignore_conflicts=false) ?(depext_only=false) then t else let t, atoms = if assume_built then - assume_built_restrictions ~available_packages t atoms + assume_built_restrictions ~task_pool ~available_packages t atoms else t, atoms in let request = @@ -1516,7 +1517,7 @@ let install_t t ?ask ?(ignore_conflicts=false) ?(depext_only=false) let packages = OpamFormula.packages_of_atoms t.packages (atoms @ deps_atoms) in let solution = let reinstall = if assume_built then Some pkg_reinstall else None in - OpamSolution.resolve t Install + OpamSolution.resolve ~task_pool t Install ~requested:packages ?reinstall request in @@ -1565,7 +1566,7 @@ let install_t t ?ask ?(ignore_conflicts=false) ?(depext_only=false) dname_map OpamPackage.Map.empty in if depext_only then - (OpamSolution.install_depexts ~force_depext:true ~confirm:false t + (OpamSolution.install_depexts ~task_pool ~force_depext:true ~confirm:false t (OpamSolver.all_packages solution)), None else let add_roots = @@ -1577,7 +1578,7 @@ let install_t t ?ask ?(ignore_conflicts=false) ?(depext_only=false) add_to_roots in let t, res = - OpamSolution.apply ?ask t + OpamSolution.apply ?ask ~task_pool t ~requested:packages ~print_requested:(print_requested requested formula) ?add_roots ~skip @@ -1589,17 +1590,17 @@ let install_t t ?ask ?(ignore_conflicts=false) ?(depext_only=false) let install t ?formula ?autoupdate ?add_to_roots ?(deps_only=false) ?(ignore_conflicts=false) ?(assume_built=false) - ?(download_only=false) ?(depext_only=false) names = + ?(download_only=false) ?(depext_only=false) ~task_pool names = let atoms = OpamSolution.sanitize_atom_list ~permissive:true t names in let autoupdate_atoms = match autoupdate with | None -> atoms | Some a -> OpamSolution.sanitize_atom_list ~permissive:true t a in let t = update_dev_packages_t autoupdate_atoms t in - install_t t atoms ?formula add_to_roots + install_t ~task_pool t atoms ?formula add_to_roots ~ignore_conflicts ~depext_only ~deps_only ~download_only ~assume_built -let remove_t ?ask ~autoremove ~force ?(formula=OpamFormula.Empty) atoms t = +let remove_t ?ask ~autoremove ~force ?(formula=OpamFormula.Empty) ~task_pool atoms t = log "REMOVE autoremove:%b %a" autoremove (slog OpamFormula.string_of_atoms) atoms; @@ -1639,7 +1640,7 @@ let remove_t ?ask ~autoremove ~force ?(formula=OpamFormula.Empty) atoms t = -- packages in let keep_cone = - keep |> OpamSwitchState.dependencies t + keep |> OpamSwitchState.dependencies ~task_pool t ~build:true ~post:true ~depopts:true ~installed:true in let autoremove = @@ -1648,11 +1649,11 @@ let remove_t ?ask ~autoremove ~force ?(formula=OpamFormula.Empty) atoms t = if atoms = [] then autoremove else (* restrict to the dependency cone of removed pkgs *) let remove_cone = - packages |> OpamSwitchState.reverse_dependencies t + packages |> OpamSwitchState.reverse_dependencies ~task_pool t ~build:true ~post:true ~depopts:false ~installed:true in autoremove %% - (remove_cone |> OpamSwitchState.dependencies t + (remove_cone |> OpamSwitchState.dependencies ~task_pool t ~build:true ~post:true ~depopts:false ~installed:true) else packages @@ -1667,7 +1668,7 @@ let remove_t ?ask ~autoremove ~force ?(formula=OpamFormula.Empty) atoms t = print_requested (OpamPackage.names_of_packages packages) formula in let t, solution = - OpamSolution.resolve_and_apply ?ask t Remove + OpamSolution.resolve_and_apply ~task_pool ?ask t Remove ~force_remove:force ~requested:packages ~print_requested @@ -1687,7 +1688,7 @@ let remove t ~autoremove ~force ?formula names = in remove_t ~autoremove ~force ?formula atoms t -let reinstall_t t ?ask ?(force=false) ~assume_built atoms = +let reinstall_t t ?ask ?(force=false) ~task_pool ~assume_built atoms = log "reinstall %a" (slog OpamFormula.string_of_atoms) atoms; let packages = OpamFormula.packages_of_atoms t.packages atoms in @@ -1723,7 +1724,7 @@ let reinstall_t t ?ask ?(force=false) ~assume_built atoms = let t, atoms = if assume_built then - assume_built_restrictions t atoms + assume_built_restrictions ~task_pool t atoms else t, atoms in @@ -1733,7 +1734,7 @@ let reinstall_t t ?ask ?(force=false) ~assume_built atoms = in let t, solution = - OpamSolution.resolve_and_apply ?ask t Reinstall + OpamSolution.resolve_and_apply ~task_pool ?ask t Reinstall ~reinstall:requested ~requested:packages ~assume_built @@ -1742,15 +1743,15 @@ let reinstall_t t ?ask ?(force=false) ~assume_built atoms = OpamSolution.check_solution t solution; t -let reinstall t ?(assume_built=false) names = +let reinstall ~task_pool t ?(assume_built=false) names = let atoms = OpamSolution.sanitize_atom_list t names in let t = update_dev_packages_t atoms t in - reinstall_t t ~assume_built atoms + reinstall_t ~task_pool t ~assume_built atoms module PIN = struct open OpamPinCommand - let post_pin_action st was_pinned names = + let post_pin_action ~task_pool st was_pinned names = let names = OpamPackage.Set.Op.(st.pinned -- was_pinned) |> OpamPackage.names_of_packages @@ -1762,6 +1763,7 @@ module PIN = struct in try upgrade_t + ~task_pool ~strict_upgrade:false ~auto_install:true ~ask:true ~terse:true ~all:false (List.map (fun name -> name, None) names) st @@ -1790,7 +1792,7 @@ module PIN = struct "No package named %S found" (OpamPackage.Name.to_string name) - let pin st name ?(edit=false) ?version ?(action=true) ?subpath ?locked target = + let pin ~task_pool st name ?(edit=false) ?version ?(action=true) ?subpath ?locked target = try let pinned = st.pinned in let st = @@ -1823,13 +1825,13 @@ module PIN = struct source_pin st name ?version ~edit ?locked (Some (get_upstream st name)) | `None -> source_pin st name ?version ~edit ?locked None in - if action then (OpamConsole.msg "\n"; post_pin_action st pinned [name]) + if action then (OpamConsole.msg "\n"; post_pin_action ~task_pool st pinned [name]) else st with | OpamPinCommand.Aborted -> OpamStd.Sys.exit_because `Aborted | OpamPinCommand.Nothing_to_do -> st - let url_pins st ?edit ?(action=true) ?locked ?(pre=fun _ -> ()) pins = + let url_pins st ?edit ?(action=true) ?locked ?(pre=fun _ -> ()) ~task_pool pins = let names = List.map (fun p -> p.pinned_name) pins in (match names with | _::_::_ -> @@ -1858,10 +1860,10 @@ module PIN = struct in if action then (OpamConsole.msg "\n"; - post_pin_action st pinned names) + post_pin_action ~task_pool st pinned names) else st - let edit st ?(action=true) ?version ?locked name = + let edit st ?(action=true) ?version ?locked ~task_pool name = let pinned = st.pinned in let st = if OpamPackage.has_name st.pinned name then @@ -1895,10 +1897,10 @@ module PIN = struct OpamConsole.error_and_exit `Not_found "Package is not pinned, and no existing version was supplied." in - if action then post_pin_action st pinned [name] + if action then post_pin_action ~task_pool st pinned [name] else st - let unpin st ?(action=true) names = + let unpin ~task_pool st ?(action=true) names = let pinned_before = st.pinned in let st = unpin st names in let installed_unpinned = (pinned_before -- st.pinned) %% st.installed in @@ -1912,7 +1914,7 @@ module PIN = struct (OpamPackage.Name.Set.of_list names) in let st, solution = - OpamSolution.resolve_and_apply st Upgrade + OpamSolution.resolve_and_apply st Upgrade ~task_pool ~requested (OpamSolver.request ~all ()) in diff --git a/src/client/opamClient.mli b/src/client/opamClient.mli index b5c21793d27..677bc9598bb 100644 --- a/src/client/opamClient.mli +++ b/src/client/opamClient.mli @@ -19,6 +19,7 @@ open OpamStateTypes Returns the initial state and, in case a switch is to be created, its initial set of packages *) val init: + task_pool:Domainslib.Task.pool -> init_config:OpamFile.InitConfig.t -> interactive:bool -> ?repo:repository -> @@ -59,12 +60,13 @@ val install: ?formula:formula -> ?autoupdate:atom list -> ?add_to_roots:bool -> ?deps_only:bool -> ?ignore_conflicts:bool -> ?assume_built:bool -> ?download_only:bool -> - ?depext_only:bool -> atom list -> + ?depext_only:bool -> task_pool:Domainslib.Task.pool -> atom list -> rw switch_state (** Low-level version of [reinstall], bypassing the package name sanitization and dev package update, and offering more control *) val install_t: + task_pool:Domainslib.Task.pool -> rw switch_state -> ?ask:bool -> ?ignore_conflicts:bool -> ?depext_only:bool -> ?download_only:bool -> atom list -> ?formula:formula -> @@ -79,12 +81,12 @@ val check_installed: (** Reinstall the given set of packages. *) val reinstall: - rw switch_state -> ?assume_built:bool -> atom list -> rw switch_state + task_pool:Domainslib.Task.pool -> rw switch_state -> ?assume_built:bool -> atom list -> rw switch_state (** Low-level version of [reinstall], bypassing the package name sanitization and dev package update, and offering more control *) val reinstall_t: - rw switch_state -> ?ask:bool -> ?force:bool -> assume_built:bool -> atom list + rw switch_state -> ?ask:bool -> ?force:bool -> task_pool:Domainslib.Task.pool -> assume_built:bool -> atom list -> rw switch_state (** Update the local mirrors for the repositories and/or development packages. @@ -101,6 +103,7 @@ val update: versions. The specified atoms are kept installed (or newly installed after a confirmation). The upgrade concerns them only unless [all] is specified. *) val upgrade: + task_pool:Domainslib.Task.pool -> rw switch_state -> ?formula:formula -> ?check:bool -> ?only_installed:bool -> all:bool -> atom list -> rw switch_state @@ -112,16 +115,16 @@ val upgrade_t: ?strict_upgrade:bool -> ?auto_install:bool -> ?ask:bool -> ?check:bool -> ?terse:bool -> ?only_installed:bool -> - all:bool -> atom list -> ?formula:formula -> + task_pool:Domainslib.Task.pool -> all:bool -> atom list -> ?formula:formula -> rw switch_state -> rw switch_state (** Recovers from an inconsistent universe *) -val fixup: ?formula:formula -> rw switch_state -> rw switch_state +val fixup: ?formula:formula -> task_pool:Domainslib.Task.pool -> rw switch_state -> rw switch_state (** Remove the given list of packages. *) val remove: rw switch_state -> autoremove:bool -> force:bool -> - ?formula:formula -> atom list -> + ?formula:formula -> atom list -> task_pool:Domainslib.Task.pool -> rw switch_state module PIN: sig @@ -129,6 +132,7 @@ module PIN: sig (** Set a package pinning. If [action], prompt for install/reinstall as appropriate after pinning. *) val pin: + task_pool:Domainslib.Task.pool -> rw switch_state -> OpamPackage.Name.t -> ?edit:bool -> ?version:version -> ?action:bool -> ?subpath:subpath -> @@ -142,17 +146,19 @@ module PIN: sig val edit: rw switch_state -> ?action:bool -> ?version:version -> ?locked:string -> + task_pool:Domainslib.Task.pool -> OpamPackage.Name.t -> rw switch_state val url_pins: rw switch_state -> ?edit:bool -> ?action:bool -> ?locked:string -> - ?pre:(pinned_opam -> unit) -> pinned_opam list -> + ?pre:(pinned_opam -> unit) -> task_pool:Domainslib.Task.pool -> pinned_opam list -> rw switch_state val unpin: + task_pool:Domainslib.Task.pool -> rw switch_state -> - ?action:bool -> OpamPackage.Name.t list -> rw switch_state + ?action:bool ->OpamPackage.Name.t list -> rw switch_state (** List the current pinned packages. *) val list: 'a switch_state -> short:bool -> unit @@ -160,6 +166,6 @@ module PIN: sig (** Runs an install/upgrade on the listed packages if necessary. [post_pin_action st was_pinned names] takes the set of packages pinned beforehand, and a list of newly pinned packages *) - val post_pin_action: rw switch_state -> package_set -> name list -> rw switch_state + val post_pin_action: task_pool:Domainslib.Task.pool -> rw switch_state -> package_set -> name list -> rw switch_state end diff --git a/src/client/opamClientConfig.ml b/src/client/opamClientConfig.ml index 9f1571cde86..35f533e9120 100644 --- a/src/client/opamClientConfig.ml +++ b/src/client/opamClientConfig.ml @@ -225,7 +225,7 @@ let opam_init ?root_dir ?strict ?solver = (* fixme: in order to not revert config file solver value, we need to check it here *) (config >>= OpamFile.Config.solver >>| - fun s -> lazy (OpamCudfSolver.custom_solver s)) + fun s -> OpamLazy.create (fun () -> OpamCudfSolver.custom_solver s)) else solver in begin match config with @@ -237,11 +237,11 @@ let opam_init ?root_dir ?strict ?solver = in OpamSolverConfig.update ?solver - ?solver_preferences_default:(criteria `Default >>| fun s-> lazy(Some s)) - ?solver_preferences_upgrade:(criteria `Upgrade >>| fun s-> lazy(Some s)) - ?solver_preferences_fixup:(criteria `Fixup >>| fun s -> lazy (Some s)) + ?solver_preferences_default:(criteria `Default >>| fun s-> OpamLazy.create (fun () ->Some s)) + ?solver_preferences_upgrade:(criteria `Upgrade >>| fun s-> OpamLazy.create (fun () ->Some s)) + ?solver_preferences_fixup:(criteria `Fixup >>| fun s -> OpamLazy.create (fun () ->Some s)) ?solver_preferences_best_effort_prefix: - (OpamFile.Config.best_effort_prefix conf >>| fun s -> lazy (Some s)) + (OpamFile.Config.best_effort_prefix conf >>| fun s -> OpamLazy.create (fun () ->Some s)) (); OpamStateConfig.update () diff --git a/src/client/opamClientConfig.mli b/src/client/opamClientConfig.mli index be286dfc5ea..6bae8897aed 100644 --- a/src/client/opamClientConfig.mli +++ b/src/client/opamClientConfig.mli @@ -97,7 +97,7 @@ val search_files: string list val opam_init: ?root_dir:OpamTypes.dirname -> ?strict:bool -> - ?solver:(module OpamCudfSolver.S) Lazy.t -> + ?solver:(module OpamCudfSolver.S) OpamLazy.t -> ?skip_version_checks:bool -> ?all_parens:bool -> ?log_dir:OpamTypes.dirname -> @@ -122,13 +122,13 @@ val opam_init: ?scrubbed_environment_variables:string list -> ?current_switch:OpamSwitch.t -> ?switch_from:OpamStateTypes.provenance -> - ?jobs:int Lazy.t -> + ?jobs:int OpamLazy.t -> ?dl_jobs:int -> ?build_test:bool -> ?build_doc:bool -> ?dev_setup:bool -> ?dryrun:bool -> - ?makecmd:string Lazy.t -> + ?makecmd:string OpamLazy.t -> ?ignore_constraints_on:OpamPackage.Name.Set.t -> ?unlock_base:bool -> ?no_env_notice:bool -> @@ -136,17 +136,17 @@ val opam_init: ?no_depexts:bool -> ?cudf_file:string option -> ?best_effort:bool -> - ?solver_preferences_default:string option Lazy.t -> - ?solver_preferences_upgrade:string option Lazy.t -> - ?solver_preferences_fixup:string option Lazy.t -> - ?solver_preferences_best_effort_prefix: string option Lazy.t -> + ?solver_preferences_default:string option OpamLazy.t -> + ?solver_preferences_upgrade:string option OpamLazy.t -> + ?solver_preferences_fixup:string option OpamLazy.t -> + ?solver_preferences_best_effort_prefix: string option OpamLazy.t -> ?solver_timeout:float option -> ?solver_allow_suboptimal:bool -> ?cudf_trim:string option -> ?dig_depth:int -> ?preprocess:bool -> ?version_lag_power:int -> - ?download_tool:(OpamTypes.arg list * OpamRepositoryConfig.dl_tool_kind) Lazy.t -> + ?download_tool:(OpamTypes.arg list * OpamRepositoryConfig.dl_tool_kind) OpamLazy.t -> ?validation_hook:OpamTypes.arg list option -> ?retries:int -> ?force_checksums:bool option -> diff --git a/src/client/opamCommands.ml b/src/client/opamCommands.ml index efc820a46d2..f9d53f79cc5 100644 --- a/src/client/opamCommands.ml +++ b/src/client/opamCommands.ml @@ -472,8 +472,10 @@ let init cli = { repo_name; repo_url; repo_trust = None }) repo_url in + OpamMulticore.run_with_task_pool @@ fun task_pool -> let gt, rt, default_compiler = OpamClient.init + ~task_pool ~init_config ~interactive ?repo ~bypass_checks ?dot_profile ?update_config ?env_hook ?completion @@ -497,26 +499,26 @@ let init cli = OpamConsole.header_msg "Creating initial switch '%s' (invariant %s%s)" name (match invariant with - | OpamFormula.Empty -> "empty" - | c -> OpamFileTools.dep_formula_to_string c) + | OpamFormula.Empty -> "empty" + | c -> OpamFileTools.dep_formula_to_string c) (match default_compiler with - | [] -> "" - | comp -> " - initially with "^ (OpamFormula.string_of_atoms comp)); + | [] -> "" + | comp -> " - initially with "^ (OpamFormula.string_of_atoms comp)); let (), st = try OpamSwitchCommand.create gt ~rt ~invariant ~update_config:true (OpamSwitch.of_string name) @@ (fun st -> - (), - OpamSwitchCommand.install_compiler st - ~ask:false - ~additional_installs:default_compiler) + (), + OpamSwitchCommand.install_compiler ~task_pool st + ~ask:false + ~additional_installs:default_compiler) with e -> OpamStd.Exn.finalise e @@ fun () -> OpamConsole.note "Opam has been initialised, but the initial switch creation \ - failed.\n\ - Use 'opam switch create ' to get started." + failed.\n\ + Use 'opam switch create ' to get started." in OpamSwitchState.drop st in @@ -727,47 +729,48 @@ let list ?(force_search=false) cli = OpamConsole.msg "# Packages matching: %s\n" (OpamListCommand.string_of_formula filter); let all = OpamPackage.Set.union st.packages st.installed in + OpamMulticore.run_with_task_pool @@ fun task_pool -> let results = - OpamListCommand.filter ~base:all st filter + OpamListCommand.filter ~task_pool ~base:all st filter in if not no_depexts && not silent then (let drop_by_depexts = - List.fold_left (fun missing str -> - let is_missing pkgs = - if OpamStd.String.contains_char str '.' then - let nv = OpamPackage.of_string str in - if OpamPackage.Set.mem nv results then None else - OpamPackage.Set.find_opt (OpamPackage.equal nv) pkgs - else - let n = OpamPackage.Name.of_string str in - if OpamPackage.has_name results n then None else - let exist = OpamPackage.packages_of_name pkgs n in - if OpamPackage.Set.is_empty exist then None else - Some (OpamPackage.Set.max_elt exist) - in - match OpamStd.Option.Op.( - is_missing OpamPackage.Set.Op.(st.packages ++ st.pinned) - >>= OpamSwitchState.depexts_unavailable st) with - | Some nf -> OpamStd.String.Map.add str nf missing - | None -> missing - | exception Failure _ -> missing (* invalid package *) - ) OpamStd.String.Map.empty packages - in - if not (OpamStd.String.Map.is_empty drop_by_depexts) then - OpamConsole.note - "Some packages are unavailable because of their external dependencies. \ + List.fold_left (fun missing str -> + let is_missing pkgs = + if OpamStd.String.contains_char str '.' then + let nv = OpamPackage.of_string str in + if OpamPackage.Set.mem nv results then None else + OpamPackage.Set.find_opt (OpamPackage.equal nv) pkgs + else + let n = OpamPackage.Name.of_string str in + if OpamPackage.has_name results n then None else + let exist = OpamPackage.packages_of_name pkgs n in + if OpamPackage.Set.is_empty exist then None else + Some (OpamPackage.Set.max_elt exist) + in + match OpamStd.Option.Op.( + is_missing OpamPackage.Set.Op.(st.packages ++ st.pinned) + >>= OpamSwitchState.depexts_unavailable st) with + | Some nf -> OpamStd.String.Map.add str nf missing + | None -> missing + | exception Failure _ -> missing (* invalid package *) + ) OpamStd.String.Map.empty packages + in + if not (OpamStd.String.Map.is_empty drop_by_depexts) then + OpamConsole.note + "Some packages are unavailable because of their external dependencies. \ Use `--no-depexts' to show them anyway.\n%s" - (OpamStd.Format.itemize (fun (n, spkgs) -> + (OpamStd.Format.itemize (fun (n, spkgs) -> Printf.sprintf "%s: %s" n (OpamStd.Format.pretty_list - (List.map OpamSysPkg.to_string + (List.map OpamSysPkg.to_string (OpamSysPkg.Set.elements spkgs)))) - (OpamStd.String.Map.bindings drop_by_depexts))); + (OpamStd.String.Map.bindings drop_by_depexts))); if not depexts then (if not silent then - OpamListCommand.display st format results - else if OpamPackage.Set.is_empty results then - OpamStd.Sys.exit_because `False) + OpamListCommand.display ~task_pool st format results + else if OpamPackage.Set.is_empty results then + OpamStd.Sys.exit_because `False) else let results_depexts = OpamListCommand.get_depexts st results in if not silent then @@ -850,32 +853,33 @@ let tree ?(why=false) cli = in let tree global_options mode filter post dev doc test dev_setup no_constraint no_switch recurse subpath atoms_or_locals () = + OpamMulticore.run_with_task_pool @@ fun task_pool -> if atoms_or_locals = [] && no_switch then `Error (true, "--no-switch can't be used without specifying a package or a path") else (apply_global_options cli global_options; - OpamGlobalState.with_ `Lock_none @@ fun gt -> - OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> - (if no_switch then + OpamGlobalState.with_ `Lock_none @@ fun gt -> + OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> + (if no_switch then fun k -> k @@ OpamSwitchState.load_virtual gt rt else OpamSwitchState.with_ `Lock_none ~rt gt) @@ fun st -> - let st, atoms = - OpamAuxCommands.simulate_autopin - st ~recurse ?subpath ~quiet:true - ?locked:OpamStateConfig.(!r.locked) atoms_or_locals - in - let tog = OpamListCommand.{ - post; test; doc; dev; dev_setup; - recursive = false; - depopts = false; - build = true; - } in - OpamTreeCommand.run st tog ~no_constraint mode filter atoms; - `Ok ()) - in + let st, atoms = + OpamAuxCommands.simulate_autopin + st ~recurse ?subpath ~quiet:true + ?locked:OpamStateConfig.(!r.locked) atoms_or_locals + in + let tog = OpamListCommand.{ + post; test; doc; dev; dev_setup; + recursive = false; + depopts = false; + build = true; + } in + OpamTreeCommand.run ~task_pool st tog ~no_constraint mode filter atoms; + `Ok ()) +in mk_command_ret ~cli (cli_from cli2_2) "tree" ~doc ~man Term.(const tree $global_options cli $mode $filter $post cli $dev cli $doc_flag cli $test cli $dev_setup cli @@ -1388,13 +1392,14 @@ let config cli = | None -> OpamStd.Sys.guess_shell_compat () in let pwsh = match shell with SH_pwsh _ -> true | _ -> false in + OpamMulticore.run_with_task_pool @@ fun task_pool -> match command, params with | Some `env, [] -> OpamGlobalState.with_ `Lock_none @@ fun gt -> (match OpamStateConfig.get_switch_opt () with - | None -> `Ok () - | Some sw -> - `Ok (OpamConfigCommand.env gt sw + | None -> `Ok () + | Some sw -> + `Ok (OpamConfigCommand.env gt sw ~set_opamroot ~set_opamswitch ~csh:(shell=SH_csh) ~sexp ~fish:(shell=SH_fish) ~pwsh ~cmd:(shell=SH_cmd) @@ -1402,9 +1407,9 @@ let config cli = | Some `revert_env, [] -> OpamGlobalState.with_ `Lock_none @@ fun gt -> (match OpamStateConfig.get_switch_opt () with - | None -> `Ok () - | Some sw -> - `Ok (OpamConfigCommand.ensure_env gt sw; + | None -> `Ok () + | Some sw -> + `Ok (OpamConfigCommand.ensure_env gt sw; OpamConfigCommand.print_eval_env ~csh:(shell=SH_csh) ~sexp ~fish:(shell=SH_fish) ~pwsh ~cmd:(shell=SH_cmd) @@ -1417,42 +1422,43 @@ let config cli = OpamSwitchState.with_ `Lock_none gt @@ fun st -> (try `Ok (OpamConfigCommand.list st (List.map OpamPackage.Name.of_string params)) - with Failure msg -> `Error (false, msg)) + with Failure msg -> `Error (false, msg)) | Some `expand, [str] -> OpamGlobalState.with_ `Lock_none @@ fun gt -> `Ok (OpamConfigCommand.expand gt str) | Some `var, [var] -> OpamGlobalState.with_ `Lock_none @@ fun gt -> (try `Ok (OpamConfigCommand.var_show gt var) - with Failure msg -> `Error (false, msg)) + with Failure msg -> `Error (false, msg)) | Some `subst, (_::_ as files) -> OpamGlobalState.with_ `Lock_none @@ fun gt -> `Ok (OpamConfigCommand.subst gt - (List.map OpamFilename.Base.of_string files)) + (List.map OpamFilename.Base.of_string files)) | Some `pef, params -> OpamGlobalState.with_ `Lock_none @@ fun gt -> OpamSwitchState.with_ `Lock_none gt @@ fun st -> (match params with - | [] | ["-"] -> OpamSwitchState.dump_pef_state st stdout; `Ok () - | [file] -> - let oc = open_out file in - OpamSwitchState.dump_pef_state st oc; - close_out oc; - `Ok () - | _ -> bad_subcommand ~cli commands ("config", command, params)) + | [] | ["-"] -> OpamSwitchState.dump_pef_state st stdout; `Ok () + | [file] -> + let oc = open_out file in + OpamSwitchState.dump_pef_state st oc; + close_out oc; + `Ok () + | _ -> bad_subcommand ~cli commands ("config", command, params)) | Some `cudf, params -> OpamGlobalState.with_ `Lock_none @@ fun gt -> OpamSwitchState.with_ `Lock_none gt @@ fun opam_state -> let opam_univ = OpamSwitchState.universe opam_state ~requested:opam_state.packages + ~task_pool Query in - let dump oc = OpamSolver.dump_universe opam_univ oc in + let dump oc = OpamSolver.dump_universe ~task_pool opam_univ oc in (match params with - | [] -> `Ok (dump stdout) - | [file] -> let oc = open_out file in dump oc; close_out oc; `Ok () - | _ -> bad_subcommand ~cli commands ("config", command, params)) + | [] -> `Ok (dump stdout) + | [file] -> let oc = open_out file in dump oc; close_out oc; `Ok () + | _ -> bad_subcommand ~cli commands ("config", command, params)) | Some `report, [] -> ( let print label fmt = OpamConsole.msg ("# %-20s "^^fmt^^"\n") label in OpamConsole.msg "# opam config report\n"; @@ -1460,13 +1466,13 @@ let config cli = (OpamVersion.to_string (OpamVersion.full ())); print "self-upgrade" "%s" (if self_upgrade_status global_options = `Running then - OpamFilename.prettify - (fst (self_upgrade_exe (OpamStateConfig.(!r.root_dir)))) - else "no"); + OpamFilename.prettify + (fst (self_upgrade_exe (OpamStateConfig.(!r.root_dir)))) + else "no"); try OpamGlobalState.with_ `Lock_none @@ fun gt -> print "system" "%s" (OpamSysPoll.to_string gt.global_variables); - let module Solver = (val OpamSolverConfig.(Lazy.force !r.solver)) in + let module Solver = (val OpamSolverConfig.(OpamLazy.force !r.solver)) in print "solver" "%s" (OpamCudfSolver.get_name (module Solver)); print "install-criteria" "%s" @@ -1476,19 +1482,19 @@ let config cli = let nprint label n = if n <> 0 then [Printf.sprintf "%d (%s)" n label] else [] in - print "jobs" "%d" (Lazy.force OpamStateConfig.(!r.jobs)); + print "jobs" "%d" (OpamLazy.force OpamStateConfig.(!r.jobs)); match OpamStateConfig.get_switch_opt () with | None -> print "current-switch" "%s" "none set"; `Ok () | Some switch -> OpamSwitchState.with_ `Lock_none ~switch gt @@ fun state -> print "repositories" "%s" (let repos = state.switch_repos.repositories in - let default, nhttp, nlocal, nvcs = - OpamRepositoryName.Map.fold - (fun _ repo (dft, nhttp, nlocal, nvcs) -> + let default, nhttp, nlocal, nvcs = + OpamRepositoryName.Map.fold + (fun _ repo (dft, nhttp, nlocal, nvcs) -> let dft = if OpamUrl.root repo.repo_url = - OpamUrl.root OpamInitDefaults.repository_url + OpamUrl.root OpamInitDefaults.repository_url then OpamRepositoryName.Map.find repo.repo_name @@ -1500,35 +1506,35 @@ let config cli = | `http -> dft, nhttp+1, nlocal, nvcs | `rsync -> dft, nhttp, nlocal+1, nvcs | _ -> dft, nhttp, nlocal, nvcs+1) - repos (None,0,0,0) - in - String.concat ", " - (nprint "http" nhttp @ + repos (None,0,0,0) + in + String.concat ", " + (nprint "http" nhttp @ nprint "local" nlocal @ nprint "version-controlled" nvcs) ^ - match default with - | Some v -> Printf.sprintf " (default repo at %s)" v - | None -> "" + match default with + | Some v -> Printf.sprintf " (default repo at %s)" v + | None -> "" ); print "pinned" "%s" (if OpamPackage.Set.is_empty state.pinned then "0" else - let pinnings = - OpamPackage.Set.fold (fun nv acc -> - let opam = OpamSwitchState.opam state nv in - let kind = - if Some opam = + let pinnings = + OpamPackage.Set.fold (fun nv acc -> + let opam = OpamSwitchState.opam state nv in + let kind = + if Some opam = OpamPackage.Map.find_opt nv state.repos_package_index - then "version" - else - OpamStd.Option.to_string ~none:"local" - (fun u -> OpamUrl.string_of_backend u.OpamUrl.backend) - (OpamFile.OPAM.get_url opam) - in - OpamStd.String.Map.update kind succ 0 acc) - state.pinned OpamStd.String.Map.empty - in - String.concat ", " - (List.flatten (List.map (fun (k,v) -> nprint k v) + then "version" + else + OpamStd.Option.to_string ~none:"local" + (fun u -> OpamUrl.string_of_backend u.OpamUrl.backend) + (OpamFile.OPAM.get_url opam) + in + OpamStd.String.Map.update kind succ 0 acc) + state.pinned OpamStd.String.Map.empty + in + String.concat ", " + (List.flatten (List.map (fun (k,v) -> nprint k v) (OpamStd.String.Map.bindings pinnings))) ); print "current-switch" "%s" @@ -1536,10 +1542,10 @@ let config cli = print "invariant" "%s" (OpamFormula.to_string state.switch_invariant); print "compiler-packages" "%s" - (let packages = OpamSwitchState.compiler_packages state in - if OpamPackage.Set.is_empty packages then "none" else - String.concat ", " - (List.map OpamPackage.to_string + (let packages = OpamSwitchState.compiler_packages ~task_pool state in + if OpamPackage.Set.is_empty packages then "none" else + String.concat ", " + (List.map OpamPackage.to_string (OpamPackage.Set.elements packages))); let process nv = try @@ -1547,7 +1553,7 @@ let config cli = let bindings = let f (name, value) = (OpamVariable.Full.create nv.name name, - OpamVariable.string_of_variable_contents value) + OpamVariable.string_of_variable_contents value) in List.map f (OpamFile.Dot_config.bindings conf) in @@ -1563,7 +1569,7 @@ let config cli = match OpamSwitchState.opam_opt state p with | Some o -> OpamFile.OPAM.has_flag Pkgflag_Compiler o | None -> false) - |> OpamSwitchState.dependencies ~depopts:true ~post:true ~build:true + |> OpamSwitchState.dependencies ~task_pool ~depopts:true ~post:true ~build:true ~installed:true state |> OpamPackage.Set.iter process; if not Sys.win32 && List.mem "." (OpamStd.Sys.split_path_variable (Sys.getenv "PATH")) @@ -1575,7 +1581,7 @@ let config cli = | Some `exec, (_::_ as c) -> OpamGlobalState.with_ `Lock_none @@ fun gt -> `Ok (OpamConfigCommand.exec - gt ~set_opamroot ~set_opamswitch ~inplace_path ~no_switch:false c) + gt ~set_opamroot ~set_opamswitch ~inplace_path ~no_switch:false c) | Some (`set | `unset as cmd), var::value -> let args = match cmd,value with @@ -1584,16 +1590,16 @@ let config cli = | _, _ -> None in (match args with - | None -> - bad_subcommand ~cli commands ("config", command, params) - | Some opt_value -> - OpamGlobalState.with_ `Lock_none @@ fun gt -> - let value = - OpamStd.Option.map_default (fun v -> `Overwrite v) - `Revert opt_value - in - let _ = OpamConfigCommand.set_var_switch gt var value in - `Ok ()) + | None -> + bad_subcommand ~cli commands ("config", command, params) + | Some opt_value -> + OpamGlobalState.with_ `Lock_none @@ fun gt -> + let value = + OpamStd.Option.map_default (fun v -> `Overwrite v) + `Revert opt_value + in + let _ = OpamConfigCommand.set_var_switch gt var value in + `Ok ()) | Some (`set_global | `unset_global as cmd), var::value -> let args = match cmd,value with @@ -1602,19 +1608,18 @@ let config cli = | _, _ -> None in (match args with - | None -> - bad_subcommand ~cli commands ("config", command, params) - | Some opt_value -> - OpamGlobalState.with_ `Lock_write @@ fun gt -> - let value = - OpamStd.Option.map_default (fun v -> `Overwrite v) - `Revert opt_value - in - let _gt = OpamConfigCommand.set_var_global gt var value in - `Ok ()) + | None -> + bad_subcommand ~cli commands ("config", command, params) + | Some opt_value -> + OpamGlobalState.with_ `Lock_write @@ fun gt -> + let value = + OpamStd.Option.map_default (fun v -> `Overwrite v) + `Revert opt_value + in + let _gt = OpamConfigCommand.set_var_global gt var value in + `Ok ()) | command, params -> bad_subcommand ~cli commands ("config", command, params) - in - +in mk_command_ret ~cli cli_original "config" ~doc ~man Term.(const config $global_options cli $command $shell_opt cli cli_original $sexp cli @@ -1807,12 +1812,13 @@ let install cli = download_only atoms_or_locals () = apply_global_options cli global_options; apply_build_options cli build_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> if atoms_or_locals = [] && not restore && formula = OpamFormula.Empty then `Error (true, "required argument PACKAGES is missing") else if assume_built && (deps_only || formula <> OpamFormula.Empty || depext_only) then `Error (true, "option --assume-built is not compatible with --deps-only, \ - --formula or --depext-only") + --formula or --depext-only") else if depext_only && (OpamClientConfig.(!r.assume_depexts) @@ -1820,7 +1826,7 @@ let install cli = `Error (true, Printf.sprintf "--depext-only and --%s can't be used together" (if OpamClientConfig.(!r.assume_depexts) then "assume-depexts" - else "no-depexts")) + else "no-depexts")) else OpamGlobalState.with_ `Lock_none @@ fun gt -> OpamSwitchState.with_ `Lock_write gt @@ fun st -> @@ -1836,7 +1842,7 @@ let install cli = else OpamConsole.msg "Packages to be restored: %s\n" (OpamPackage.Name.Set.to_string - (OpamPackage.names_of_packages to_restore)); + (OpamPackage.names_of_packages to_restore)); atoms_or_locals @ List.map (fun p -> `Atom (OpamSolution.atom_of_package p)) (OpamPackage.Set.elements to_restore) @@ -1850,27 +1856,27 @@ let install cli = in if formula = OpamFormula.Empty && atoms = [] then (OpamConsole.msg "Nothing to do\n"; - OpamStd.Sys.exit_because `Success); + OpamStd.Sys.exit_because `Success); if check then - let missing = - OpamPackage.Map.fold (fun _ -> OpamPackage.Name.Set.union) - (OpamClient.check_installed ~build:true ~post:true st atoms) - (OpamPackage.Name.Set.empty) - in - if OpamPackage.Name.Set.is_empty missing then - (OpamConsole.errmsg "All dependencies installed\n"; + let missing = + OpamPackage.Map.fold (fun _ -> OpamPackage.Name.Set.union) + (OpamClient.check_installed ~build:true ~post:true st atoms) + (OpamPackage.Name.Set.empty) + in + if OpamPackage.Name.Set.is_empty missing then + (OpamConsole.errmsg "All dependencies installed\n"; OpamStd.Sys.exit_because `Success) - else - (OpamConsole.errmsg "Missing dependencies:\n"; + else + (OpamConsole.errmsg "Missing dependencies:\n"; OpamConsole.msg "%s\n" (OpamStd.List.concat_map " " OpamPackage.Name.to_string - (OpamPackage.Name.Set.elements missing)); + (OpamPackage.Name.Set.elements missing)); OpamStd.Sys.exit_because `False) else let st = - OpamClient.install st atoms ~formula - ~autoupdate:pure_atoms ?add_to_roots ~deps_only ~ignore_conflicts - ~assume_built ~depext_only ~download_only + OpamClient.install ~task_pool st atoms ~formula + ~autoupdate:pure_atoms ?add_to_roots ~deps_only ~ignore_conflicts + ~assume_built ~depext_only ~download_only in match destdir with | None -> `Ok () @@ -1878,7 +1884,7 @@ let install cli = let packages = OpamFormula.packages_of_atoms st.installed atoms in OpamAuxCommands.copy_files_to_destdir st dest packages; `Ok () - in +in mk_command_ret ~cli cli_original "install" ~doc ~man Term.(const install $global_options cli $build_options cli $add_to_roots $deps_only $ignore_conflicts $restore $destdir @@ -1928,6 +1934,7 @@ let remove cli = subpath formula atom_locs () = apply_global_options cli global_options; apply_build_options cli build_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> OpamGlobalState.with_ `Lock_none @@ fun gt -> match destdir with | Some d -> @@ -1941,7 +1948,7 @@ let remove cli = if uninst <> [] then OpamConsole.warning "Can't remove the following packages from the given destdir, they \ - need to be installed in opam: %s" + need to be installed in opam: %s" (OpamStd.List.concat_map " " OpamFormula.short_string_of_atom uninst); OpamAuxCommands.remove_files_from_destdir st d packages | None -> @@ -1962,8 +1969,8 @@ let remove cli = in let autoremove = autoremove || OpamClientConfig.(!r.autoremove) in OpamSwitchState.drop - (OpamClient.remove st ~autoremove ~force ~formula atoms) - in + (OpamClient.remove ~task_pool st ~autoremove ~force ~formula atoms) +in mk_command ~cli cli_original "remove" ~doc ~man Term.(const remove $global_options cli $build_options cli $autoremove $force $destdir $recurse cli $subpath cli $formula_flag cli @@ -2004,22 +2011,23 @@ let reinstall cli = atoms_locs cmd () = apply_global_options cli global_options; apply_build_options cli build_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> let open OpamPackage.Set.Op in OpamGlobalState.with_ `Lock_none @@ fun gt -> match cmd, atoms_locs with | `Default, (_::_ as atom_locs) -> OpamSwitchState.with_ `Lock_write gt @@ fun st -> - OpamSwitchState.drop @@ OpamClient.reinstall st ~assume_built + OpamSwitchState.drop @@ OpamClient.reinstall ~task_pool st ~assume_built (OpamAuxCommands.resolve_locals_pinned st ~recurse ?subpath atom_locs); `Ok () | `Pending, [] | `Default, [] -> OpamSwitchState.with_ `Lock_write gt @@ fun st -> - let atoms = OpamSolution.eq_atoms_of_packages (Lazy.force st.reinstall) in - OpamSwitchState.drop @@ OpamClient.reinstall st atoms; + let atoms = OpamSolution.eq_atoms_of_packages (OpamLazy.force st.reinstall) in + OpamSwitchState.drop @@ OpamClient.reinstall ~task_pool st atoms; `Ok () | `List_pending, [] -> OpamSwitchState.with_ `Lock_none gt @@ fun st -> - OpamListCommand.display st + OpamListCommand.display ~task_pool st { OpamListCommand.default_package_listing_format with OpamListCommand. columns = [OpamListCommand.Package]; @@ -2027,12 +2035,12 @@ let reinstall cli = header = false; order = `Dependency; } - (Lazy.force st.reinstall); + (OpamLazy.force st.reinstall); `Ok () | `Forget_pending, atom_locs -> OpamSwitchState.with_ `Lock_write gt @@ fun st -> let atoms = OpamAuxCommands.resolve_locals_pinned ~recurse ?subpath st atom_locs in - let reinstall = Lazy.force st.reinstall in + let reinstall = OpamLazy.force st.reinstall in let to_forget = match atoms with | [] -> reinstall | atoms -> OpamFormula.packages_of_atoms reinstall atoms @@ -2042,14 +2050,14 @@ let reinstall cli = let installed = OpamPackage.Map.find nv st.installed_opams in let upstream = OpamPackage.Map.find nv st.opams in if not (OpamFile.OPAM.effectively_equal installed upstream) && - OpamConsole.confirm - "Metadata of %s were updated. Force-update, without performing \ + OpamConsole.confirm + "Metadata of %s were updated. Force-update, without performing \ the reinstallation?" (OpamPackage.to_string nv) then OpamSwitchAction.install_metadata st nv with Not_found -> ()) to_forget; let reinstall = reinstall -- to_forget in - OpamSwitchState.drop @@ OpamSwitchAction.update_switch_state ~reinstall st; + OpamSwitchState.drop @@ OpamSwitchAction.update_switch_state ~task_pool ~reinstall st; `Ok () | _, _::_ -> `Error (true, "Package arguments not allowed with this option") @@ -2106,8 +2114,9 @@ let update cli = let update global_options jobs names repos_only dev_only depexts_only all check upgrade () = apply_global_options cli global_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> OpamStateConfig.update - ?jobs:OpamStd.Option.Op.(jobs >>| fun j -> lazy j) + ?jobs:OpamStd.Option.Op.(jobs >>| fun j -> OpamLazy.create (fun () -> j)) (); OpamClientConfig.update (); OpamGlobalState.with_ `Lock_write @@ fun gt -> @@ -2125,13 +2134,13 @@ let update cli = if upgrade then OpamSwitchState.with_ `Lock_write gt ~rt @@ fun st -> OpamConsole.msg "\n"; - OpamSwitchState.drop @@ OpamClient.upgrade st ~check ~all:true [] + OpamSwitchState.drop @@ OpamClient.upgrade ~task_pool st ~check ~all:true [] else if check then OpamStd.Sys.exit_because (if changed then `Success else `False) else if changed then OpamConsole.msg "Now run 'opam upgrade' to apply any package updates.\n"; if not success then OpamStd.Sys.exit_because `Sync_error - in +in mk_command ~cli cli_original "update" ~doc ~man Term.(const update $global_options cli $jobs_flag cli cli_original $name_list $repos_only $dev_only $depexts_only $all $check $upgrade) @@ -2175,6 +2184,7 @@ let upgrade cli = recurse subpath formula atom_locs () = apply_global_options cli global_options; apply_build_options cli build_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> let all = all || atom_locs = [] in OpamGlobalState.with_ `Lock_none @@ fun gt -> if fixup then @@ -2182,7 +2192,7 @@ let upgrade cli = `Error (true, Printf.sprintf "--fixup doesn't allow extra arguments") else OpamSwitchState.with_ `Lock_write gt @@ fun st -> - OpamSwitchState.drop @@ OpamClient.fixup ~formula st; + OpamSwitchState.drop @@ OpamClient.fixup ~task_pool ~formula st; `Ok () else OpamSwitchState.with_ `Lock_write gt @@ fun st -> @@ -2190,9 +2200,9 @@ let upgrade cli = OpamAuxCommands.resolve_locals_pinned st ~recurse ?subpath atom_locs in OpamSwitchState.drop @@ - OpamClient.upgrade st ~check ~only_installed ~all ~formula atoms; + OpamClient.upgrade ~task_pool st ~check ~only_installed ~all ~formula atoms; `Ok () - in +in mk_command_ret ~cli cli_original "upgrade" ~doc ~man Term.(const upgrade $global_options cli $build_options cli $fixup $check $installed $all $recurse cli $subpath cli $formula_flag cli @@ -2795,10 +2805,11 @@ let switch cli = no_switch packages formula empty descr full freeze no_install deps_only repos force no_action d_alias_of d_no_autoinstall params () = + OpamMulticore.run_with_task_pool @@ fun task_pool -> if d_alias_of <> None then OpamConsole.warning "Option %s is deprecated, ignoring it. \ - Use instead 'opam switch '" + Use instead 'opam switch '" (OpamConsole.colorise `bold "--alias-of"); if d_no_autoinstall then OpamConsole.warning "Option %s is deprecated, ignoring it." @@ -2828,16 +2839,16 @@ let switch cli = else OpamConsole.error_and_exit `Bad_arguments "Individual package and option '--packages' can not be specified at \ - the same time. Use just '--packages' instead, e.g.\n\ - opam switch create flambda \ - --packages=ocaml.4.12.0,ocaml-option-flambda\n\ - or '--formula'\n\ - opam switch create flambda \ - --formula='[\"ocaml\" {=\"4.12.0\"} \"ocaml-option-flambda\"]'" + the same time. Use just '--packages' instead, e.g.\n\ + opam switch create flambda \ + --packages=ocaml.4.12.0,ocaml-option-flambda\n\ + or '--formula'\n\ + opam switch create flambda \ + --formula='[\"ocaml\" {=\"4.12.0\"} \"ocaml-option-flambda\"]'" | _ -> OpamConsole.error_and_exit `Bad_arguments "Individual packages, options --packages, --formula and --empty may \ - not be specified at the same time" + not be specified at the same time" in match command, params with | None , [] @@ -2852,17 +2863,17 @@ let switch cli = let st = OpamSwitchState.load_virtual ?repos_list:repos gt rt in OpamConsole.msg "# Listing available compilers from repositories: %s\n" (OpamStd.List.concat_map ", " OpamRepositoryName.to_string - (OpamStd.Option.default (OpamGlobalState.repos_list gt) repos)); + (OpamStd.Option.default (OpamGlobalState.repos_list gt) repos)); let filters = List.map (fun patt -> OpamListCommand.Pattern ({ OpamListCommand.default_pattern_selector with - OpamListCommand.fields = ["name"; "version"] }, - patt)) + OpamListCommand.fields = ["name"; "version"] }, + patt)) pattlist in let compilers = - OpamListCommand.filter ~base:compilers st + OpamListCommand.filter ~task_pool ~base:compilers st (OpamFormula.ands (List.map (fun f -> OpamFormula.Atom f) filters)) in let format = @@ -2874,14 +2885,14 @@ let switch cli = then OpamPackage.Name.compare nv1.name nv2.name else OpamPackage.Version.compare nv1.version nv2.version in - OpamListCommand.display st + OpamListCommand.display ~task_pool st {OpamListCommand.default_package_listing_format - with OpamListCommand. - short = print_short; - header = not print_short; - columns = format; - all_versions = true; - order = `Custom order; + with OpamListCommand. + short = print_short; + header = not print_short; + columns = format; + all_versions = true; + order = `Custom order; } compilers; `Ok () @@ -2900,73 +2911,73 @@ let switch cli = else params in (match invariant_arg ?repos rt pkg_params with - | exception Failure e -> `Error (false, e) - | invariant_opt -> - let invariant = - OpamStd.Option.default - (OpamFile.Config.default_invariant rt.repos_global.config) - invariant_opt - in - let (), st = - OpamSwitchCommand.create gt ~rt - ?synopsis:descr ?repos - ~update_config:(not no_switch) - ~invariant - switch - @@ fun st -> - let st, additional_installs = - if use_local then - let st, atoms = - OpamAuxCommands.autopin st ~simulate:deps_only ~quiet:true - ?locked:OpamStateConfig.(!r.locked) - [`Dirname (OpamFilename.Dir.of_string switch_arg)] - in - let st = - if is_implicit then - let local_compilers = - OpamStd.List.filter_map - (fun (name, _) -> + | exception Failure e -> `Error (false, e) + | invariant_opt -> + let invariant = + OpamStd.Option.default + (OpamFile.Config.default_invariant rt.repos_global.config) + invariant_opt + in + let (), st = + OpamSwitchCommand.create gt ~rt + ?synopsis:descr ?repos + ~update_config:(not no_switch) + ~invariant + switch + @@ fun st -> + let st, additional_installs = + if use_local then + let st, atoms = + OpamAuxCommands.autopin st ~simulate:deps_only ~quiet:true + ?locked:OpamStateConfig.(!r.locked) + [`Dirname (OpamFilename.Dir.of_string switch_arg)] + in + let st = + if is_implicit then + let local_compilers = + OpamStd.List.filter_map + (fun (name, _) -> (* The opam file for the local package might not be - the current pinning (e.g. with deps-only), but it's - guaranteed to be the only available version by - autopin. *) + the current pinning (e.g. with deps-only), but it's + guaranteed to be the only available version by + autopin. *) match OpamSwitchState.opam st (OpamPackage.package_of_name - (Lazy.force st.available_packages) - name) + (OpamLazy.force st.available_packages) + name) with | opam -> if OpamFile.OPAM.has_flag Pkgflag_Compiler opam then Some (Atom (name, None)) else None | exception Not_found -> None) - atoms - in - if local_compilers <> [] then - OpamSwitchCommand.set_invariant_raw st - OpamFormula.(of_atom_formula (ands local_compilers)) - else st - else st - in - st, atoms - else st, [] - in - (), - OpamSwitchCommand.install_compiler st - ~additional_installs - ~deps_only - ~ask:(additional_installs <> []) - in - OpamSwitchState.drop st; - `Ok ()) + atoms + in + if local_compilers <> [] then + OpamSwitchCommand.set_invariant_raw st + OpamFormula.(of_atom_formula (ands local_compilers)) + else st + else st + in + st, atoms + else st, [] + in + (), + OpamSwitchCommand.install_compiler ~task_pool st + ~additional_installs + ~deps_only + ~ask:(additional_installs <> []) + in + OpamSwitchState.drop st; + `Ok ()) | Some `export, [filename] -> OpamGlobalState.with_ `Lock_none @@ fun gt -> OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> OpamSwitchCommand.export rt ~full:(full || freeze) ~freeze (if filename = "-" then None - else Some (OpamFile.make (OpamFilename.of_string filename))); + else Some (OpamFile.make (OpamFilename.of_string filename))); `Ok () | Some `import, [filename] -> OpamGlobalState.with_ `Lock_none @@ fun gt -> @@ -2987,7 +2998,7 @@ let switch cli = ~update_config:(not no_switch) switch @@ fun st -> - let st = OpamSwitchCommand.import st import_source in + let st = OpamSwitchCommand.import ~task_pool st import_source in let invariant = OpamSwitchState.infer_switch_invariant st in let st = OpamSwitchCommand.set_invariant_raw st invariant in st.switch_global, st @@ -3001,7 +3012,7 @@ let switch cli = OpamConsole.warning "Switch exists, '--repositories' argument ignored"; OpamSwitchState.with_ `Lock_write gt ~switch @@ fun st -> - OpamSwitchState.drop @@ OpamSwitchCommand.import st import_source + OpamSwitchState.drop @@ OpamSwitchCommand.import ~task_pool st import_source end; `Ok () | Some `remove, switches -> @@ -3009,13 +3020,13 @@ let switch cli = let _gt = List.fold_left (fun gt switch -> - let opam_dir = OpamFilename.Op.( - OpamFilename.Dir.of_string switch / OpamSwitch.external_dirname - ) in - if OpamFilename.is_symlink_dir opam_dir then - (OpamFilename.rmdir opam_dir; + let opam_dir = OpamFilename.Op.( + OpamFilename.Dir.of_string switch / OpamSwitch.external_dirname + ) in + if OpamFilename.is_symlink_dir opam_dir then + (OpamFilename.rmdir opam_dir; gt) - else OpamSwitchCommand.remove gt (OpamSwitch.of_string switch)) + else OpamSwitchCommand.remove gt (OpamSwitch.of_string switch)) gt switches in @@ -3030,7 +3041,7 @@ let switch cli = in OpamGlobalState.with_ `Lock_none @@ fun gt -> OpamSwitchState.with_ `Lock_write gt ~switch @@ fun st -> - OpamSwitchState.drop @@ OpamSwitchCommand.reinstall st; + OpamSwitchState.drop @@ OpamSwitchCommand.reinstall ~task_pool st; `Ok () | Some `current, [] -> OpamSwitchCommand.show (); @@ -3057,62 +3068,62 @@ let switch cli = OpamSwitchState.with_ `Lock_write gt @@ fun st -> let repos = OpamSwitchState.repos_list st in (match invariant_arg ~repos rt params with - | exception Failure e -> `Error (false, e) - | invariant_opt -> - let invariant = match invariant_opt with - | Some i -> i - | None -> OpamSwitchState.infer_switch_invariant st - in - let st = OpamSwitchCommand.set_invariant ~force st invariant in - OpamConsole.msg "The switch invariant was set to %s\n" - (OpamFormula.to_string invariant); - let st = - if no_action || OpamFormula.satisfies_depends st.installed invariant - then OpamSwitchAction.update_switch_state st - else - OpamClient.install_t st ~ask:true [] None ~formula:invariant - ~deps_only:false ~assume_built:false - in - OpamSwitchState.drop st; - `Ok ()) + | exception Failure e -> `Error (false, e) + | invariant_opt -> + let invariant = match invariant_opt with + | Some i -> i + | None -> OpamSwitchState.infer_switch_invariant st + in + let st = OpamSwitchCommand.set_invariant ~force st invariant in + OpamConsole.msg "The switch invariant was set to %s\n" + (OpamFormula.to_string invariant); + let st = + if no_action || OpamFormula.satisfies_depends st.installed invariant + then OpamSwitchAction.update_switch_state ~task_pool st + else + OpamClient.install_t ~task_pool st ~ask:true [] None ~formula:invariant + ~deps_only:false ~assume_built:false + in + OpamSwitchState.drop st; + `Ok ()) | Some `link, args -> (try - let switch, dir = match args with - | switch::dir::[] -> - OpamSwitch.of_string switch, - OpamFilename.Dir.of_string dir - | switch::[] -> - OpamSwitch.of_string switch, - OpamFilename.cwd () - | [] -> failwith "Missing SWITCH argument" - | _::_::_::_ -> failwith "Extra argument" - in - let open OpamFilename.Op in - let linkname = dir / OpamSwitch.external_dirname in - OpamGlobalState.with_ `Lock_none @@ fun gt -> - if not (OpamGlobalState.switch_exists gt switch) then - OpamConsole.error_and_exit `Not_found - "The switch %s was not found" - (OpamSwitch.to_string switch); - if OpamFilename.is_symlink_dir linkname then - OpamFilename.rmdir linkname; - if OpamFilename.exists_dir linkname then - OpamConsole.error_and_exit `Bad_arguments - "There already is a local switch in %s. Remove it and try again." - (OpamFilename.Dir.to_string dir); - if OpamFilename.exists (dir // OpamSwitch.external_dirname) then - OpamConsole.error_and_exit `Bad_arguments - "There is a '%s' file in the way. Remove it and try again." - (OpamFilename.Dir.to_string linkname); - OpamFilename.link_dir ~link:linkname - ~target:(OpamPath.Switch.root gt.root switch); - OpamConsole.msg "Directory %s set to use switch %s.\n\ + let switch, dir = match args with + | switch::dir::[] -> + OpamSwitch.of_string switch, + OpamFilename.Dir.of_string dir + | switch::[] -> + OpamSwitch.of_string switch, + OpamFilename.cwd () + | [] -> failwith "Missing SWITCH argument" + | _::_::_::_ -> failwith "Extra argument" + in + let open OpamFilename.Op in + let linkname = dir / OpamSwitch.external_dirname in + OpamGlobalState.with_ `Lock_none @@ fun gt -> + if not (OpamGlobalState.switch_exists gt switch) then + OpamConsole.error_and_exit `Not_found + "The switch %s was not found" + (OpamSwitch.to_string switch); + if OpamFilename.is_symlink_dir linkname then + OpamFilename.rmdir linkname; + if OpamFilename.exists_dir linkname then + OpamConsole.error_and_exit `Bad_arguments + "There already is a local switch in %s. Remove it and try again." + (OpamFilename.Dir.to_string dir); + if OpamFilename.exists (dir // OpamSwitch.external_dirname) then + OpamConsole.error_and_exit `Bad_arguments + "There is a '%s' file in the way. Remove it and try again." + (OpamFilename.Dir.to_string linkname); + OpamFilename.link_dir ~link:linkname + ~target:(OpamPath.Switch.root gt.root switch); + OpamConsole.msg "Directory %s set to use switch %s.\n\ Just remove %s to unlink.\n" - (OpamConsole.colorise `cyan (OpamFilename.Dir.to_string dir)) - (OpamConsole.colorise `bold (OpamSwitch.to_string switch)) - (OpamConsole.colorise `cyan (OpamFilename.Dir.to_string linkname)); - `Ok () - with Failure e -> `Error (true, e)) + (OpamConsole.colorise `cyan (OpamFilename.Dir.to_string dir)) + (OpamConsole.colorise `bold (OpamSwitch.to_string switch)) + (OpamConsole.colorise `cyan (OpamFilename.Dir.to_string linkname)); + `Ok () + with Failure e -> `Error (true, e)) | Some `set_description, text -> let synopsis = String.concat " " text in OpamGlobalState.with_ `Lock_none @@ fun gt -> @@ -3123,7 +3134,7 @@ let switch cli = OpamSwitchAction.install_switch_config gt.root st.switch config; `Ok () | command, params -> bad_subcommand ~cli commands ("switch", command, params) - in +in mk_command_ret ~cli cli_original "switch" ~doc ~man Term.(const switch $global_options cli $build_options cli $command @@ -3393,6 +3404,7 @@ let pin ?(unpin_only=false) cli = kind edit no_act dev_repo print_short recurse subpath normalise with_version current all command params () = + OpamMulticore.run_with_task_pool @@ fun task_pool -> apply_global_options cli global_options; apply_build_options cli build_options; let locked = OpamStateConfig.(!r.locked) in @@ -3462,30 +3474,30 @@ let pin ?(unpin_only=false) cli = >>| fun url -> OpamPackage.Set.filter (fun nv -> - match OpamSwitchState.url st nv with - | Some u -> - let spu = OpamFile.URL.subpath u in - let u = OpamFile.URL.url u in - let path_equality () = - let open OpamUrl in - match subpath, recurse with - | Some sp, false -> - u.path = url.path && spu = Some sp - | Some sp, true -> - (match spu with + match OpamSwitchState.url st nv with + | Some u -> + let spu = OpamFile.URL.subpath u in + let u = OpamFile.URL.url u in + let path_equality () = + let open OpamUrl in + match subpath, recurse with + | Some sp, false -> + u.path = url.path && spu = Some sp + | Some sp, true -> + (match spu with | Some spp -> let open OpamUrl.Op in OpamStd.String.starts_with ~prefix:(url / OpamFilename.SubPath.to_string sp).path (u / OpamFilename.SubPath.to_string spp).path | None -> false) - | None, true -> - u.path = url.path - | None, false -> - spu = None && u.path = url.path - in - OpamUrl.(u.transport = url.transport) && path_equality () - | None -> false) + | None, true -> + u.path = url.path + | None, false -> + spu = None && u.path = url.path + in + OpamUrl.(u.transport = url.transport) && path_equality () + | None -> false) st.pinned |> OpamPackage.names_of_packages |> OpamPackage.Name.Set.elements @@ -3497,122 +3509,122 @@ let pin ?(unpin_only=false) cli = | `Ok (name, None) -> err, name::acc | `Ok (name, Some version) -> (match OpamPinned.version_opt st name with - | Some v when not (OpamPackage.Version.equal v version) -> - OpamConsole.error "%s is pinned but not to version %s. Skipping." - (OpamPackage.Name.to_string name) (OpamPackage.Version.to_string version); - true, acc - | Some _ | None -> err, name::acc) + | Some v when not (OpamPackage.Version.equal v version) -> + OpamConsole.error "%s is pinned but not to version %s. Skipping." + (OpamPackage.Name.to_string name) (OpamPackage.Version.to_string version); + true, acc + | Some _ | None -> err, name::acc) | `Error _ -> OpamConsole.error "No package pinned to this target found, or invalid package \ - name/url: %s" arg; + name/url: %s" arg; true, acc) (false,[]) arg in if err then OpamStd.Sys.exit_because `Bad_arguments else - (OpamSwitchState.drop @@ OpamClient.PIN.unpin st ~action to_unpin; - `Ok ()) + (OpamSwitchState.drop @@ OpamClient.PIN.unpin ~task_pool st ~action to_unpin; + `Ok ()) | `remove_all -> OpamGlobalState.with_ `Lock_none @@ fun gt -> OpamSwitchState.with_ `Lock_write gt @@ fun st -> let to_unpin = OpamPackage.Set.to_list_map OpamPackage.name (OpamPinned.packages st) in - OpamSwitchState.drop @@ OpamClient.PIN.unpin st ~action to_unpin; + OpamSwitchState.drop @@ OpamClient.PIN.unpin ~task_pool st ~action to_unpin; `Ok () | `edit nv -> (match (fst package) nv with - | `Ok (name, version) -> - OpamGlobalState.with_ `Lock_none @@ fun gt -> - OpamSwitchState.with_ `Lock_write gt @@ fun st -> - let version = OpamStd.Option.Op.(with_version ++ version) in - OpamSwitchState.drop @@ - OpamClient.PIN.edit st ?locked ~action ?version name; - `Ok () - | `Error e -> `Error (false, e)) + | `Ok (name, version) -> + OpamGlobalState.with_ `Lock_none @@ fun gt -> + OpamSwitchState.with_ `Lock_write gt @@ fun st -> + let version = OpamStd.Option.Op.(with_version ++ version) in + OpamSwitchState.drop @@ + OpamClient.PIN.edit ~task_pool st ?locked ~action ?version name; + `Ok () + | `Error e -> `Error (false, e)) | `add_normalised pins -> let pins = OpamPinCommand.parse_pins pins in OpamGlobalState.with_ `Lock_none @@ fun gt -> OpamSwitchState.with_ `Lock_write gt @@ fun st -> OpamSwitchState.drop @@ - OpamClient.PIN.url_pins st ?locked ~edit ~action + OpamClient.PIN.url_pins ~task_pool st ?locked ~edit ~action (List.map (fun pin -> - { pin with - pinned_version = - OpamStd.Option.Op.(with_version ++ pin.pinned_version)}) + { pin with + pinned_version = + OpamStd.Option.Op.(with_version ++ pin.pinned_version)}) pins); `Ok () | `add_dev nv -> (match (fst package) nv with - | `Ok (name,version) -> - OpamGlobalState.with_ `Lock_none @@ fun gt -> - OpamSwitchState.with_ `Lock_write gt @@ fun st -> - let name = OpamSolution.fuzzy_name st name in - let version = OpamStd.Option.Op.(with_version ++ version) in - OpamSwitchState.drop @@ - OpamClient.PIN.pin st name ?locked ~edit ?version ~action - `Dev_upstream; - `Ok () - | `Error e -> - if command = Some `add then `Error (false, e) - else bad_subcommand ~cli commands ("pin", command, params)) + | `Ok (name,version) -> + OpamGlobalState.with_ `Lock_none @@ fun gt -> + OpamSwitchState.with_ `Lock_write gt @@ fun st -> + let name = OpamSolution.fuzzy_name st name in + let version = OpamStd.Option.Op.(with_version ++ version) in + OpamSwitchState.drop @@ + OpamClient.PIN.pin ~task_pool st name ?locked ~edit ?version ~action + `Dev_upstream; + `Ok () + | `Error e -> + if command = Some `add then `Error (false, e) + else bad_subcommand ~cli commands ("pin", command, params)) | `add_url arg -> (match pin_target kind arg with - | `None | `Version _ -> - let msg = - Printf.sprintf "Ambiguous argument %S, if it is the pinning target, \ - you must specify a package name first" arg - in - `Error (true, msg) - | `Source url -> - guess_names kind ?locked ~recurse ?subpath url @@ fun names -> - OpamGlobalState.with_ `Lock_none @@ fun gt -> - OpamSwitchState.with_ `Lock_write gt @@ fun st -> - OpamSwitchState.drop @@ - OpamClient.PIN.url_pins st ?locked ~edit ~action - (List.map (fun pin -> + | `None | `Version _ -> + let msg = + Printf.sprintf "Ambiguous argument %S, if it is the pinning target, \ + you must specify a package name first" arg + in + `Error (true, msg) + | `Source url -> + guess_names kind ?locked ~recurse ?subpath url @@ fun names -> + OpamGlobalState.with_ `Lock_none @@ fun gt -> + OpamSwitchState.with_ `Lock_write gt @@ fun st -> + OpamSwitchState.drop @@ + OpamClient.PIN.url_pins ~task_pool st ?locked ~edit ~action + (List.map (fun pin -> { pin with pinned_version = with_version }) - names); - `Ok ()) + names); + `Ok ()) | `add_current n -> (match (fst package) n with - | `Error e -> `Error (false, e) - | `Ok (name,version) -> - OpamGlobalState.with_ `Lock_none @@ fun gt -> - OpamSwitchState.with_ `Lock_write gt @@ fun st -> - match OpamPackage.package_of_name_opt st.installed name, version with - | Some nv, Some v when nv.version <> v -> - OpamConsole.error_and_exit `Bad_arguments - "%s.%s is not installed (version %s is), invalid flag `--current'" - (OpamPackage.Name.to_string name) - (OpamPackage.Version.to_string v) - (OpamPackage.Version.to_string nv.version) - | None, _ -> - OpamConsole.error_and_exit `Bad_arguments - "%s is not installed, invalid flag `--current'" - (OpamPackage.Name.to_string name) - | Some nv, _ -> - OpamSwitchState.drop @@ - OpamPinCommand.pin_current st nv; - `Ok ()) + | `Error e -> `Error (false, e) + | `Ok (name,version) -> + OpamGlobalState.with_ `Lock_none @@ fun gt -> + OpamSwitchState.with_ `Lock_write gt @@ fun st -> + match OpamPackage.package_of_name_opt st.installed name, version with + | Some nv, Some v when nv.version <> v -> + OpamConsole.error_and_exit `Bad_arguments + "%s.%s is not installed (version %s is), invalid flag `--current'" + (OpamPackage.Name.to_string name) + (OpamPackage.Version.to_string v) + (OpamPackage.Version.to_string nv.version) + | None, _ -> + OpamConsole.error_and_exit `Bad_arguments + "%s is not installed, invalid flag `--current'" + (OpamPackage.Name.to_string name) + | Some nv, _ -> + OpamSwitchState.drop @@ + OpamPinCommand.pin_current st nv; + `Ok ()) | `add_wtarget (n, target) -> (match (fst package) n with - | `Ok (name,version) -> - let pin = - match pin_target kind target, with_version with - | `Version v, Some v' -> `Source_version (v, v') - | p, _ -> p - in - let version = OpamStd.Option.Op.(with_version ++ version) in - OpamGlobalState.with_ `Lock_none @@ fun gt -> - OpamSwitchState.with_ `Lock_write gt @@ fun st -> - OpamSwitchState.drop @@ - OpamClient.PIN.pin st name ?locked ?version ~edit ~action ?subpath pin; - `Ok () - | `Error e -> `Error (false, e)) + | `Ok (name,version) -> + let pin = + match pin_target kind target, with_version with + | `Version v, Some v' -> `Source_version (v, v') + | p, _ -> p + in + let version = OpamStd.Option.Op.(with_version ++ version) in + OpamGlobalState.with_ `Lock_none @@ fun gt -> + OpamSwitchState.with_ `Lock_write gt @@ fun st -> + OpamSwitchState.drop @@ + OpamClient.PIN.pin ~task_pool st name ?locked ?version ~edit ~action ?subpath pin; + `Ok () + | `Error e -> `Error (false, e)) | `incorrect -> bad_subcommand ~cli commands ("pin", command, params) - in +in mk_command_ret ~cli cli_original "pin" ~doc ~man Term.(const pin $global_options cli $build_options cli @@ -3651,6 +3663,7 @@ let source cli = in let source global_options atom dev_repo pin no_switch dir () = apply_global_options cli global_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> OpamGlobalState.with_ `Lock_none @@ fun gt -> let get_package_dir t = let nv = @@ -3677,7 +3690,7 @@ let source cli = if exists_dir dir then OpamConsole.error_and_exit `Bad_arguments "Directory %s already exists. Please remove it or use a different one \ - (see option `--dir')" + (see option `--dir')" (Dir.to_string dir); let opam = OpamSwitchState.opam t nv in let subpath = @@ -3686,72 +3699,72 @@ let source cli = in if dev_repo then (match OpamFile.OPAM.dev_repo opam with - | None -> - OpamConsole.error_and_exit `Not_found - "Version-controlled repo for %s unknown \ + | None -> + OpamConsole.error_and_exit `Not_found + "Version-controlled repo for %s unknown \ (\"dev-repo\" field missing from metadata)" - (OpamPackage.to_string nv) - | Some url -> - mkdir dir; - match - OpamProcess.Job.run - (OpamRepository.pull_tree + (OpamPackage.to_string nv) + | Some url -> + mkdir dir; + match + OpamProcess.Job.run + (OpamRepository.pull_tree ~cache_dir:(OpamRepositoryPath.download_cache OpamStateConfig.(!r.root_dir)) ?subpath (OpamPackage.to_string nv) dir [] [url]) - with - | Not_available (_,u) -> - OpamConsole.error_and_exit `Sync_error "%s is not available" u - | Result _ | Up_to_date _ -> - OpamConsole.formatted_msg - "Successfully fetched %s development repo to %s\n" - (OpamPackage.name_to_string nv) - (OpamFilename.Dir.to_string dir)) + with + | Not_available (_,u) -> + OpamConsole.error_and_exit `Sync_error "%s is not available" u + | Result _ | Up_to_date _ -> + OpamConsole.formatted_msg + "Successfully fetched %s development repo to %s\n" + (OpamPackage.name_to_string nv) + (OpamFilename.Dir.to_string dir)) else (let job = - let open OpamProcess.Job.Op in - OpamUpdate.download_package_source t nv dir @@+ function - | Some (Not_available (_,s)), _ | _, (_, Not_available (_, s)) :: _ -> - OpamConsole.error_and_exit `Sync_error "Download failed: %s" s - | None, _ | Some (Result _ | Up_to_date _), _ -> - OpamAction.prepare_package_source t nv dir @@| function - | None -> - OpamConsole.formatted_msg "Successfully extracted to %s\n" - (Dir.to_string dir) - | Some e -> - OpamConsole.warning "Some errors extracting to %s: %s\n" - (Dir.to_string dir) (Printexc.to_string e) - in - OpamProcess.Job.run job; - if OpamPinned.find_opam_file_in_source nv.name - OpamFilename.SubPath.(dir /? subpath) + let open OpamProcess.Job.Op in + OpamUpdate.download_package_source t nv dir @@+ function + | Some (Not_available (_,s)), _ | _, (_, Not_available (_, s)) :: _ -> + OpamConsole.error_and_exit `Sync_error "Download failed: %s" s + | None, _ | Some (Result _ | Up_to_date _), _ -> + OpamAction.prepare_package_source t nv dir @@| function + | None -> + OpamConsole.formatted_msg "Successfully extracted to %s\n" + (Dir.to_string dir) + | Some e -> + OpamConsole.warning "Some errors extracting to %s: %s\n" + (Dir.to_string dir) (Printexc.to_string e) + in + OpamProcess.Job.run job; + if OpamPinned.find_opam_file_in_source nv.name + OpamFilename.SubPath.(dir /? subpath) = None - then - let f = - if OpamFilename.exists_dir Op.(dir / "opam") - then OpamFile.make Op.(dir / "opam" // "opam") - else OpamFile.make Op.(dir // "opam") - in - OpamFile.OPAM.write f - (OpamFile.OPAM.with_substs [] @@ + then + let f = + if OpamFilename.exists_dir Op.(dir / "opam") + then OpamFile.make Op.(dir / "opam" // "opam") + else OpamFile.make Op.(dir // "opam") + in + OpamFile.OPAM.write f + (OpamFile.OPAM.with_substs [] @@ OpamFile.OPAM.with_patches [] @@ opam)) in if no_switch || OpamGlobalState.switches gt = [] then (if pin then - OpamConsole.error_and_exit `Bad_arguments - (if no_switch then + OpamConsole.error_and_exit `Bad_arguments + (if no_switch then "Options '--pin' and '--no-switch' may not be specified at the \ - same time" + same time" else "No switch is defined in current opam root, \ - pinning is impossible"); - OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> - let t = OpamSwitchState.load_virtual ?repos_list:None gt rt in - let nv, dir = get_package_dir t in - get_source t nv dir) + pinning is impossible"); + OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> + let t = OpamSwitchState.load_virtual ?repos_list:None gt rt in + let nv, dir = get_package_dir t in + get_source t nv dir) else if not pin then OpamSwitchState.with_ `Lock_none gt @@ fun t -> let nv, dir = get_package_dir t in @@ -3769,11 +3782,11 @@ let source cli = in let target = `Source (OpamUrl.parse ~backend ~from_file:false - ("file://"^OpamFilename.Dir.to_string dir)) + ("file://"^OpamFilename.Dir.to_string dir)) in OpamSwitchState.drop - (OpamClient.PIN.pin t nv.name ~version:nv.version target) - in + (OpamClient.PIN.pin ~task_pool t nv.name ~version:nv.version target) +in mk_command ~cli cli_original "source" ~doc ~man Term.(const source $global_options cli $atom $dev_repo $pin $no_switch $dir) @@ -4306,6 +4319,7 @@ let lock cli = let lock_suffix = OpamArg.lock_suffix cli in let lock global_options only_direct lock_suffix atom_locs () = apply_global_options cli global_options; + OpamMulticore.run_with_task_pool @@ fun task_pool -> OpamGlobalState.with_ `Lock_none @@ fun gt -> OpamSwitchState.with_ `Lock_none gt @@ fun st -> let st, packages = OpamLockCommand.select_packages atom_locs st in @@ -4314,13 +4328,13 @@ let lock cli = else let st = (* Suppose the packages are installed to avoid errors on mutual - dependencies *) + dependencies *) { st with installed = OpamPackage.Set.union st.installed packages } in let pkg_done = OpamPackage.Set.fold (fun nv msgs -> let opam = OpamSwitchState.opam st nv in - let locked = OpamLockCommand.lock_opam ~only_direct st opam in + let locked = OpamLockCommand.lock_opam ~task_pool ~only_direct st opam in let locked_fname = OpamFilename.add_extension (OpamFilename.of_string (OpamPackage.name_to_string nv)) @@ -4335,11 +4349,11 @@ let lock cli = in OpamConsole.msg "Generated %slock files for:\n%s" (if OpamCoreConfig.(!r).safe_mode || OpamStateConfig.(!r.dryrun) then - "(not saved) " else "") + "(not saved) " else "") (OpamStd.Format.itemize (fun (nv, file) -> - Printf.sprintf "%s: %s" - (OpamPackage.to_string nv) - (OpamFilename.to_string file)) pkg_done) + Printf.sprintf "%s: %s" + (OpamPackage.to_string nv) + (OpamFilename.to_string file)) pkg_done) in mk_command ~cli (cli_from cli2_1) "lock" ~doc ~man Term.(const lock $global_options cli $only_direct_flag $lock_suffix diff --git a/src/client/opamCommands.mli b/src/client/opamCommands.mli index fb439ba620c..edea48d1e8a 100644 --- a/src/client/opamCommands.mli +++ b/src/client/opamCommands.mli @@ -23,3 +23,4 @@ val is_admin_subcommand: string -> bool val get_cmdliner_parser: OpamCLIVersion.Sourced.t -> OpamArg.command * OpamArg.command list + diff --git a/src/client/opamConfigCommand.ml b/src/client/opamConfigCommand.ml index 326987acf00..9a55ac601fe 100644 --- a/src/client/opamConfigCommand.ml +++ b/src/client/opamConfigCommand.ml @@ -64,7 +64,7 @@ let list t ns = let possibly_unix_path_env_value k v = if k = "PATH" then - (Lazy.force OpamSystem.get_cygpath_path_transform) ~pathlist:true v + (OpamLazy.force OpamSystem.get_cygpath_path_transform) ~pathlist:true v else v let rec print_env output = function @@ -379,7 +379,7 @@ let expand gt str = let exec gt ~set_opamroot ~set_opamswitch ~inplace_path ~no_switch command = log "config-exec command=%a" (slog (String.concat " ")) command; let switch = OpamStateConfig.get_switch () in - let st_lazy = lazy ( + let st_lazy = OpamLazy.create (fun () -> let rt = OpamRepositoryState.load `Lock_none gt in OpamSwitchState.load `Lock_none gt rt switch ) in @@ -397,7 +397,7 @@ let exec gt ~set_opamroot ~set_opamswitch ~inplace_path ~no_switch command = in let env = OpamTypesBase.env_array env in let resolve var = - OpamPackageVar.resolve (Lazy.force st_lazy) var + OpamPackageVar.resolve (OpamLazy.force st_lazy) var in let cmd, args = match @@ -663,7 +663,7 @@ let allwd_wrappers wdef wrappers with_wrappers = let switch_allowed_fields, switch_allowed_sections = let allowed_fields = - lazy ( + OpamLazy.create (fun () -> OpamFile.Switch_config.( [ ("synopsis", Atomic, @@ -703,7 +703,7 @@ let switch_allowed_fields, switch_allowed_sections = let rem_elem new_elems elems = List.filter (fun n -> not (List.mem n new_elems)) elems in - lazy ( + OpamLazy.create (fun () -> OpamFile.Switch_config.([ ("variables", InModifiable ( (fun nc c -> { c with variables = nc.variables @ c.variables }), @@ -712,8 +712,8 @@ let switch_allowed_fields, switch_allowed_sections = (fun c -> { c with variables = empty.variables })); ])) in - (fun () -> Lazy.force allowed_fields), - fun () -> Lazy.force allowed_sections + (fun () -> OpamLazy.force allowed_fields), + fun () -> OpamLazy.force allowed_sections let confset_switch gt switch switch_config = let config_f = OpamPath.Switch.switch_config gt.root switch in @@ -768,7 +768,7 @@ let set_opt_switch gt ?st field value = let global_allowed_fields, global_allowed_sections = let allowed_fields = - lazy ( + OpamLazy.create (fun () -> let open OpamStd.Option.Op in let open OpamFile in let in_config = OpamInitDefaults.init_config () in @@ -876,7 +876,7 @@ let global_allowed_fields, global_allowed_sections = @ allwd_wrappers wrapper_init Config.wrappers Config.with_wrappers ) in - (fun () -> Lazy.force allowed_fields), + (fun () -> OpamLazy.force allowed_fields), fun () -> [] let confset_global gt = @@ -1115,7 +1115,7 @@ let vars_list_global gt = match OpamStd.Option.Op.( OpamVariable.Map.find_opt var gt.global_variables >>| fst - >>= Lazy.force) with + >>= OpamLazy.force) with | Some c when (OpamVariable.string_of_variable_contents c) <> content -> "Set through local opam config or env" diff --git a/src/client/opamInitDefaults.ml b/src/client/opamInitDefaults.ml index ed5fb85a5f4..e1334b5f297 100644 --- a/src/client/opamInitDefaults.ml +++ b/src/client/opamInitDefaults.ml @@ -124,7 +124,7 @@ let dl_tool () = >>| fun cmd -> [(CString cmd), None] let recommended_tools () = - let make = OpamStateConfig.(Lazy.force !r.makecmd) in + let make = OpamStateConfig.(OpamLazy.force !r.makecmd) in [ [make], None, None; ["cc"], None, Some not_win32_filter; diff --git a/src/client/opamListCommand.ml b/src/client/opamListCommand.ml index 327e8c1569d..8a01ba989b2 100644 --- a/src/client/opamListCommand.ml +++ b/src/client/opamListCommand.ml @@ -164,7 +164,7 @@ let atom_dependencies st tog atoms = OpamFormula.ors [acc; package_dependencies st tog nv]) pkgs OpamFormula.Empty -let get_universe st ?requested tog = +let get_universe ~task_pool st ?requested tog = let requested = match requested with | Some r -> r @@ -172,7 +172,7 @@ let get_universe st ?requested tog = in OpamSwitchState.universe st ~test:tog.test ~doc:tog.doc ~dev_setup:tog.dev_setup ~force_dev_deps:tog.dev - ~requested Query + ~requested ~task_pool Query let rec value_strings value = let module SS = OpamStd.String.Set in @@ -211,22 +211,22 @@ let pattern_selector patterns = Atom (Pattern (version_patt, version))]) patterns) -let apply_selector ~base st = function +let apply_selector ~task_pool ~base st = function | Any -> base | Installed -> st.installed | Root -> st.installed_roots | Compiler -> OpamSwitchState.invariant_root_packages st - | Available -> Lazy.force st.available_packages + | Available -> OpamLazy.force st.available_packages | Installable -> - OpamSolver.installable_subset - (OpamSwitchState.universe st ~requested:OpamPackage.Set.empty Query) + OpamSolver.installable_subset ~task_pool + (OpamSwitchState.universe st ~requested:OpamPackage.Set.empty ~task_pool Query) base | Pinned -> OpamPinned.packages st | (Required_by ({recursive=true; _} as tog, atoms) | Depends_on ({recursive=true; _} as tog, atoms)) as direction -> let deps_fun = match direction with - | Required_by _ -> OpamSwitchState.dependencies - | Depends_on _ -> OpamSwitchState.reverse_dependencies + | Required_by _ -> OpamSwitchState.dependencies ~task_pool + | Depends_on _ -> OpamSwitchState.reverse_dependencies ~task_pool | _ -> assert false in deps_fun ~depopts:tog.depopts ~build:tog.build ~post:tog.post @@ -246,22 +246,22 @@ let apply_selector ~base st = function OpamSwitchState.conflicts_with st (OpamPackage.Set.of_list packages) base | Coinstallable_with (tog, packages) -> - let universe = get_universe st tog in + let universe = get_universe ~task_pool st tog in let set = OpamPackage.Set.of_list packages in - OpamSolver.coinstallable_subset universe set base + OpamSolver.coinstallable_subset ~task_pool universe set base | Solution (tog, atoms) -> let universe = let requested = OpamFormula.packages_of_atoms st.packages atoms in - get_universe st tog ~requested + get_universe ~task_pool st tog ~requested in let universe = { universe with u_installed = OpamPackage.Set.empty; u_installed_roots = OpamPackage.Set.empty } in - (match OpamSolver.resolve universe + (match OpamSolver.resolve ~task_pool universe (OpamSolver.request ~install:atoms ()) with | Success s -> OpamSolver.new_packages s | Conflicts cs -> @@ -368,14 +368,14 @@ let apply_selector ~base st = function OpamPackage.Set.empty) -let rec filter ~base st = function +let rec filter ~task_pool ~base st = function | Empty -> base - | Atom select -> base %% apply_selector ~base st select - | Block b -> filter ~base st b + | Atom select -> base %% apply_selector ~task_pool ~base st select + | Block b -> filter ~task_pool ~base st b | And (a, b) -> - let base = filter ~base st a in - filter ~base st b - | Or (a, b) -> filter ~base st a ++ filter ~base st b + let base = filter ~task_pool ~base st a in + filter ~task_pool ~base st b + | Or (a, b) -> filter ~task_pool ~base st a ++ filter ~task_pool ~base st b type output_format = | Name @@ -598,7 +598,7 @@ let detail_printer ?prettify ?normalise ?(sort=false) st nv = String.concat " " | Available_versions -> let available = - OpamPackage.packages_of_name (Lazy.force st.available_packages) nv.name + OpamPackage.packages_of_name (OpamLazy.force st.available_packages) nv.name in OpamStd.List.concat_map " " (fun nv -> OpamPackage.Version.to_string nv.version % version_color st nv) @@ -663,7 +663,7 @@ let default_package_listing_format = { order = `Standard; } -let display st format packages = +let display ~task_pool st format packages = let packages = if format.all_versions then packages else OpamPackage.Name.Set.fold (fun name -> @@ -672,7 +672,7 @@ let display st format packages = let get = OpamPackage.Set.max_elt in try get (pkgs %% st.installed) with Not_found -> try get (pkgs %% st.pinned) with Not_found -> - try get (pkgs %% Lazy.force st.available_packages) with Not_found -> + try get (pkgs %% OpamLazy.force st.available_packages) with Not_found -> get pkgs in OpamPackage.Set.add nv) @@ -684,9 +684,10 @@ let display st format packages = let universe = OpamSwitchState.universe st ~requested:packages + ~task_pool Query in - OpamSolver.dependency_sort ~depopts:true ~build:true ~post:false + OpamSolver.dependency_sort ~task_pool ~depopts:true ~build:true ~post:false universe packages else match format.order with | `Custom o -> List.sort o (OpamPackage.Set.elements packages) @@ -847,7 +848,7 @@ let info st ~fields ~raw ~where ?normalise ?(show_empty=false) (let choose = try OpamPackage.Set.choose (nvs %% st.pinned) with Not_found -> try OpamPackage.Set.choose (nvs %% st.installed) with Not_found -> - try OpamPackage.Set.max_elt (nvs %% Lazy.force st.available_packages) + try OpamPackage.Set.max_elt (nvs %% OpamLazy.force st.available_packages) with Not_found -> OpamPackage.Set.max_elt nvs in diff --git a/src/client/opamListCommand.mli b/src/client/opamListCommand.mli index 5d1f1c50199..662ec6d57c8 100644 --- a/src/client/opamListCommand.mli +++ b/src/client/opamListCommand.mli @@ -64,6 +64,7 @@ type selector = (** Applies a formula of selectors to filter the package from a given switch state *) val filter: + task_pool:Domainslib.Task.pool -> base:package_set -> 'a switch_state -> selector OpamFormula.formula -> package_set @@ -142,7 +143,7 @@ val default_package_listing_format: package_listing_format [normalise] supersedes [prettify] and uses a canonical way of displaying package definition file fields. [prettify] uses a nicer to read format for the package definition file fields. *) -val display: 'a switch_state -> package_listing_format -> package_set -> unit +val display: task_pool:Domainslib.Task.pool -> 'a switch_state -> package_listing_format -> package_set -> unit (** Display a general summary of a collection of packages. *) val info: diff --git a/src/client/opamLockCommand.ml b/src/client/opamLockCommand.ml index a17556981da..1d662af4699 100644 --- a/src/client/opamLockCommand.ml +++ b/src/client/opamLockCommand.ml @@ -128,11 +128,11 @@ let get_git_url url nv dir = (OpamPackage.to_string nv); None) -let lock_opam ?(only_direct=false) st opam = +let lock_opam ?(only_direct=false) ~task_pool st opam = let nv = OpamFile.OPAM.package opam in (* Depends *) let all_depends = - OpamSwitchState.dependencies + OpamSwitchState.dependencies ~task_pool ~depopts:true ~build:true ~post:true ~installed:true st (OpamPackage.Set.singleton nv) |> OpamPackage.Set.remove nv @@ -175,7 +175,7 @@ let lock_opam ?(only_direct=false) st opam = let depends_map = map_of_set `other installed in if only_direct then depends_map else - (OpamSwitchState.dependencies + (OpamSwitchState.dependencies ~task_pool ~depopts:false ~build:true ~post:true ~installed:true st installed -- all_depends) diff --git a/src/client/opamLockCommand.mli b/src/client/opamLockCommand.mli index 8438b745e37..f35431b4b8d 100644 --- a/src/client/opamLockCommand.mli +++ b/src/client/opamLockCommand.mli @@ -22,4 +22,4 @@ val select_packages: 'a switch_state -> 'a switch_state * package_set (** Returns the locked opam file, according its depends, depopts, and pins. *) -val lock_opam: ?only_direct:bool -> 'a switch_state -> OpamFile.OPAM.t -> OpamFile.OPAM.t +val lock_opam: ?only_direct:bool -> task_pool:Domainslib.Task.pool -> 'a switch_state -> OpamFile.OPAM.t -> OpamFile.OPAM.t diff --git a/src/client/opamPinCommand.ml b/src/client/opamPinCommand.ml index 3ec2b4731e6..3c88debf20f 100644 --- a/src/client/opamPinCommand.ml +++ b/src/client/opamPinCommand.ml @@ -689,12 +689,12 @@ let unpin_one st nv = OpamPackage.Map.filter (fun nv2 _ -> nv2.name = nv.name) st.repos_package_index in - let available_packages = lazy ( + let available_packages = OpamLazy.create (fun () -> OpamSwitchState.compute_available_packages st.switch_global st.switch st.switch_config ~pinned:OpamPackage.Set.empty ~opams:repo_package |> OpamPackage.Set.union - (OpamPackage.Set.remove nv (Lazy.force st.available_packages)) + (OpamPackage.Set.remove nv (OpamLazy.force st.available_packages)) ) in match OpamPackage.Map.find_opt nv st.repos_package_index, OpamPackage.Map.find_opt nv st.installed_opams with diff --git a/src/client/opamSolution.ml b/src/client/opamSolution.ml index 4b7576483af..a9b21e432c2 100644 --- a/src/client/opamSolution.ml +++ b/src/client/opamSolution.ml @@ -214,8 +214,8 @@ let sanitize_atom_list ?(permissive=false) ?(installed=false) t atoms = (t.packages ++ t.installed) atoms else check_availability t - (if installed then t.installed ++ Lazy.force t.available_packages - else Lazy.force t.available_packages) + (if installed then t.installed ++ OpamLazy.force t.available_packages + else OpamLazy.force t.available_packages) atoms; atoms @@ -310,7 +310,7 @@ end (* Process the atomic actions in a graph in parallel, respecting graph order, and report to user. Takes a graph of atomic actions *) let parallel_apply t - ~requested ?add_roots ~assume_built ~download_only ?(force_remove=false) + ~task_pool ~requested ?add_roots ~assume_built ~download_only ?(force_remove=false) action_graph = log "parallel_apply"; @@ -374,12 +374,12 @@ let parallel_apply t let add_conf conf = OpamPackage.Name.Map.add nv.name conf t.conf_files in OpamStd.Option.map_default add_conf t.conf_files conf in - t_ref := OpamSwitchAction.add_to_installed {t with conf_files} ~root nv; + t_ref := OpamSwitchAction.add_to_installed ~task_pool {t with conf_files} ~root nv; let missing_depexts = (* Turns out these depexts weren't needed after all. Remember that and make the bypass permanent. *) try - (OpamPackage.Map.find nv (Lazy.force !t_ref.sys_packages)).s_available + (OpamPackage.Map.find nv (OpamLazy.force !t_ref.sys_packages)).s_available with Not_found -> OpamSysPkg.Set.empty in let bypass = OpamSysPkg.Set.union missing_depexts !bypass_ref in @@ -442,7 +442,7 @@ let parallel_apply t in let remove_from_install ?keep_as_root nv = - t_ref := OpamSwitchAction.remove_from_installed ?keep_as_root !t_ref nv + t_ref := OpamSwitchAction.remove_from_installed ?keep_as_root ~task_pool !t_ref nv in let inplace = @@ -743,7 +743,7 @@ let parallel_apply t in let results = PackageActionGraph.Parallel.map - ~jobs:(Lazy.force OpamStateConfig.(!r.jobs)) + ~jobs:(OpamLazy.force OpamStateConfig.(!r.jobs)) ~command:job ~dry_run:OpamStateConfig.(!r.dryrun) ~pools @@ -1120,7 +1120,7 @@ let get_depexts ?(force=false) ?(recover=false) t packages = if recover then OpamSwitchState.depexts_status_of_packages t packages else - let base = Lazy.force t.sys_packages in + let base = OpamLazy.force t.sys_packages in (* workaround: st.sys_packages is not always updated with added packages *) let more_pkgs = @@ -1146,7 +1146,7 @@ let get_depexts ?(force=false) ?(recover=false) t packages = print_depext_msg (avail, nf); avail -let install_depexts ?(force_depext=false) ?(confirm=true) t packages = +let install_depexts ?(force_depext=false) ?(confirm=true) ~task_pool:_ t packages = let confirm = confirm && not (OpamSysInteract.Cygwin.is_internal t.switch_global.config) in @@ -1166,9 +1166,9 @@ let install_depexts ?(force_depext=false) ?(confirm=true) t packages = sys_map | None -> sys_map) packages - (Lazy.force t.sys_packages) + (OpamLazy.force t.sys_packages) in - { t with sys_packages = lazy sys_packages } + { t with sys_packages = OpamLazy.create (fun () -> sys_packages) } in let rec entry_point t sys_packages = if OpamClientConfig.(!r.fake) then @@ -1298,7 +1298,7 @@ let install_depexts ?(force_depext=false) ?(confirm=true) t packages = with Sys.Break as e -> OpamStd.Exn.finalise e give_up_msg (* Apply a solution *) -let apply ?ask t ~requested ?print_requested ?add_roots +let apply ?ask ~task_pool t ~requested ?print_requested ?add_roots ?(skip=OpamPackage.Map.empty) ?(assume_built=false) ?(download_only=false) ?force_remove solution0 = @@ -1320,7 +1320,7 @@ let apply ?ask t ~requested ?print_requested ?add_roots if OpamClientConfig.(!r.show) then let _ = get_depexts t virt_inst in t (* Prints the msg about additional depexts to install *) - else install_depexts t virt_inst + else install_depexts ~task_pool t virt_inst in t, Nothing_to_do else ( @@ -1368,8 +1368,8 @@ let apply ?ask t ~requested ?print_requested ?add_roots pinned ^ deprecated in OpamSolver.print_solution ~messages ~append - ~requested:print_requested ~reinstall:(Lazy.force t.reinstall) - ~available:(Lazy.force t.available_packages) + ~requested:print_requested ~reinstall:(OpamLazy.force t.reinstall) + ~available:(OpamLazy.force t.available_packages) ~skip solution0; ); @@ -1379,7 +1379,7 @@ let apply ?ask t ~requested ?print_requested ?add_roots t, Aborted else if download_only || confirmation ?ask names solution then ( let t = - install_depexts t @@ OpamPackage.Set.inter + install_depexts ~task_pool t @@ OpamPackage.Set.inter new_state0.installed (OpamSolver.all_packages solution0) in let requested = @@ -1429,6 +1429,7 @@ let apply ?ask t ~requested ?print_requested ?add_roots let t0 = t in let t, r = parallel_apply t + ~task_pool ~requested ?add_roots ~assume_built ~download_only ?force_remove action_graph in @@ -1453,21 +1454,21 @@ let apply ?ask t ~requested ?print_requested ?add_roots t, Aborted ) -let resolve t action ?reinstall ~requested request = +let resolve ~task_pool t action ?reinstall ~requested request = if OpamClientConfig.(!r.json_out <> None) then OpamJson.append "switch" (OpamSwitch.to_json t.switch); OpamRepositoryState.check_last_update (); let universe = - OpamSwitchState.universe t ~requested ?reinstall action + OpamSwitchState.universe t ~requested ?reinstall ~task_pool action in Json.output_request request action; - let r = OpamSolver.resolve universe request in + let r = OpamSolver.resolve ~task_pool universe request in Json.output_solution t r; r -let resolve_and_apply ?ask t action ?reinstall ~requested ?print_requested +let resolve_and_apply ?ask t action ?reinstall ~task_pool ~requested ?print_requested ?add_roots ?(assume_built=false) ?download_only ?force_remove request = - match resolve t action ?reinstall ~requested request with + match resolve ~task_pool t action ?reinstall ~requested request with | Conflicts cs -> log "conflict!"; OpamConsole.msg "%s" @@ -1476,7 +1477,7 @@ let resolve_and_apply ?ask t action ?reinstall ~requested ?print_requested t, Conflicts cs | Success solution -> let t, res = - apply ?ask t + apply ?ask ~task_pool t ~requested ?print_requested ?add_roots ~assume_built ?download_only ?force_remove solution diff --git a/src/client/opamSolution.mli b/src/client/opamSolution.mli index 7e3a6ece557..1d1b7bf4ad3 100644 --- a/src/client/opamSolution.mli +++ b/src/client/opamSolution.mli @@ -16,6 +16,7 @@ open OpamStateTypes (** Resolve an user request *) val resolve: + task_pool:Domainslib.Task.pool -> 'a switch_state -> user_action -> ?reinstall:package_set -> @@ -32,6 +33,7 @@ val resolve: requested packages, used for printing actions reasons. *) val apply: ?ask:bool -> + task_pool:Domainslib.Task.pool -> rw switch_state -> requested:package_set -> ?print_requested:OpamPackage.Name.Set.t -> @@ -54,6 +56,7 @@ val resolve_and_apply: rw switch_state -> user_action -> ?reinstall:package_set -> + task_pool:Domainslib.Task.pool -> requested:package_set -> ?print_requested:OpamPackage.Name.Set.t -> ?add_roots:OpamPackage.Name.Set.t -> @@ -80,7 +83,7 @@ val dry_run: 'a switch_state -> OpamSolver.solution -> 'a switch_state launched, without asking user (used by the `--depext-only` option). If [force_depext] is true, it overrides [OpamFile.Config.depext] value. *) val install_depexts: - ?force_depext:bool -> ?confirm:bool -> rw switch_state -> package_set -> rw switch_state + ?force_depext:bool -> ?confirm:bool -> task_pool:Domainslib.Task.pool -> rw switch_state -> package_set -> rw switch_state (** {2 Atoms} *) diff --git a/src/client/opamSwitchCommand.ml b/src/client/opamSwitchCommand.ml index 10466bd666a..ac6bad4e2e6 100644 --- a/src/client/opamSwitchCommand.ml +++ b/src/client/opamSwitchCommand.ml @@ -193,7 +193,7 @@ let set_invariant_raw st invariant = st let install_compiler - ?(additional_installs=[]) ?(deps_only=false) ?(ask=false) t = + ?(additional_installs=[]) ?(deps_only=false) ?(ask=false) ~task_pool t = let invariant = t.switch_invariant in if invariant = OpamFormula.Empty && additional_installs = [] then begin (if not OpamClientConfig.(!r.show) && @@ -215,7 +215,7 @@ let install_compiler OpamConsole.msg "Switch invariant: %s\n" (OpamFileTools.dep_formula_to_string invariant); let solution = - OpamSolution.resolve t Switch + OpamSolution.resolve ~task_pool t Switch ~requested:(OpamPackage.packages_of_names t.packages roots) (OpamSolver.request ~install:additional_installs ()) in @@ -260,7 +260,7 @@ let install_compiler in let t = let base_comp = - OpamSwitchState.compute_invariant_packages + OpamSwitchState.compute_invariant_packages ~task_pool { t with installed = t.installed -- (OpamSolver.removed_packages solution) ++ (OpamSolver.new_packages solution) } @@ -279,6 +279,7 @@ let install_compiler in let t, result = OpamSolution.apply t + ~task_pool ~ask:(OpamClientConfig.(!r.show) || ask) ~requested:(OpamPackage.packages_of_names t.packages roots) ~add_roots:roots ~skip @@ -320,7 +321,8 @@ let create in let st = { st with switch_invariant = invariant; switch_config } in let available_packages = - lazy (OpamSwitchState.compute_available_packages gt switch switch_config + OpamLazy.create (fun () -> + OpamSwitchState.compute_available_packages gt switch switch_config ~pinned:OpamPackage.Set.empty ~opams:st.opams) in @@ -390,7 +392,7 @@ let switch_previous lock gt = OpamConsole.error_and_exit `Not_found "No previously used switch could be found" -let import_t ?ask importfile t = +let import_t ?ask ~task_pool importfile t = log "import switch"; let extra_files = importfile.OpamFile.SwitchExport.extra_files in @@ -429,7 +431,8 @@ let import_t ?ask importfile t = in let t = { t with reinstall = - lazy OpamPackage.Set.Op.(Lazy.force t.reinstall ++ to_reinstall) } + OpamLazy.create (fun () -> + OpamPackage.Set.Op.(OpamLazy.force t.reinstall ++ to_reinstall)) } in let opams = @@ -465,7 +468,7 @@ let import_t ?ask importfile t = let t = { t with - available_packages = lazy available; + available_packages = OpamLazy.create (fun () -> available); packages; compiler_packages; pinned; @@ -499,8 +502,7 @@ let import_t ?ask importfile t = in let add_roots = OpamPackage.names_of_packages import_sel.sel_roots in - - OpamSolution.resolve_and_apply ?ask t Import + OpamSolution.resolve_and_apply ?ask t Import ~task_pool ~requested:((to_install %% available) ++ unavailable_version) ~add_roots (OpamSolver.request ~install:to_import ()) @@ -653,7 +655,7 @@ let show () = OpamConsole.msg "%s\n" (OpamSwitch.to_string (OpamStateConfig.get_switch ())) -let reinstall init_st = +let reinstall ~task_pool init_st = let switch = init_st.switch in log "reinstall switch=%a" (slog OpamSwitch.to_string) switch; let gt = init_st.switch_global in @@ -671,9 +673,9 @@ let reinstall init_st = { init_st with installed = OpamPackage.Set.empty; installed_roots = OpamPackage.Set.empty; - reinstall = lazy OpamPackage.Set.empty; } + reinstall = OpamLazy.create (fun () -> OpamPackage.Set.empty); } in - import_t { OpamFile.SwitchExport. + import_t ~task_pool { OpamFile.SwitchExport. selections = OpamSwitchState.selections init_st; extra_files = OpamHash.Map.empty; overlays = OpamPackage.Name.Map.empty; } diff --git a/src/client/opamSwitchCommand.mli b/src/client/opamSwitchCommand.mli index 8e56b5c8fd6..73cdb879c50 100644 --- a/src/client/opamSwitchCommand.mli +++ b/src/client/opamSwitchCommand.mli @@ -37,12 +37,13 @@ val create: defaults to [false]. *) val install_compiler: ?additional_installs:atom list -> ?deps_only:bool -> ?ask:bool -> - rw switch_state -> rw switch_state + task_pool:Domainslib.Task.pool -> rw switch_state -> rw switch_state (** Import a file which contains the packages to install. *) val import: rw switch_state -> OpamFile.SwitchExport.t OpamFile.t option -> + task_pool:Domainslib.Task.pool -> rw switch_state (** Export a file which contains the installed packages. If [full] is specified @@ -70,7 +71,7 @@ val switch: 'a lock -> rw global_state -> switch -> unit val switch_previous: 'a lock -> rw global_state -> unit (** Reinstall the given compiler switch. *) -val reinstall: rw switch_state -> rw switch_state +val reinstall: task_pool:Domainslib.Task.pool -> rw switch_state -> rw switch_state (** Updates the switch invariant and the associated config files, and writes the config file unless [show] or [dry_run] are activated globally. Low-level diff --git a/src/client/opamTreeCommand.ml b/src/client/opamTreeCommand.ml index e1331327b85..0b5a71c0e5e 100644 --- a/src/client/opamTreeCommand.ml +++ b/src/client/opamTreeCommand.ml @@ -135,11 +135,11 @@ let cut_leaves (mode: [ `succ | `pred]) ~names ~root st graph = (* return the new roots and the new graph *) OpamPackage.Set.inter root packages, graph -let build_deps_forest st universe tog filter names = +let build_deps_forest ~task_pool st universe tog filter names = let OpamListCommand.{ build; post; _ } = tog in let root, graph = let graph = - OpamSolver.dependency_graph + OpamSolver.dependency_graph ~task_pool ~depopts:false ~build ~post ~installed:true universe in let root = @@ -182,11 +182,11 @@ let build_deps_forest st universe tog filter names = |> OpamStd.List.fold_left_map build_root OpamPackage.Set.empty |> snd -let build_revdeps_forest st universe tog filter names = +let build_revdeps_forest ~task_pool st universe tog filter names = let OpamListCommand.{ build; post; _ } = tog in let root, graph = let graph = - OpamSolver.dependency_graph + OpamSolver.dependency_graph ~task_pool ~depopts:false ~build ~post ~installed:true universe in let root = @@ -233,12 +233,12 @@ let build_revdeps_forest st universe tog filter names = |> OpamStd.List.fold_left_map build_root OpamPackage.Set.empty |> snd -let build st universe tog mode filter names = +let build ~task_pool st universe tog mode filter names = match mode with | Deps -> - DepsForest (build_deps_forest st universe tog filter names) + DepsForest (build_deps_forest ~task_pool st universe tog filter names) | ReverseDeps -> - RevdepsForest (build_revdeps_forest st universe tog filter names) + RevdepsForest (build_revdeps_forest ~task_pool st universe tog filter names) (* Forest printing *) @@ -365,12 +365,12 @@ let print_solution st new_st missing solution = let skip = OpamPackage.Set.fold (fun p m -> OpamPackage.Map.add p p m) - (Lazy.force new_st.reinstall) + (OpamLazy.force new_st.reinstall) OpamPackage.Map.empty in OpamSolver.print_solution ~messages ~append - ~requested:missing ~reinstall:(Lazy.force st.reinstall) - ~available:(Lazy.force st.available_packages) + ~requested:missing ~reinstall:(OpamLazy.force st.reinstall) + ~available:(OpamLazy.force st.available_packages) ~skip (* hide recompiled packages because they don't make sense here *) solution; OpamConsole.msg "\n" @@ -384,13 +384,13 @@ let get_universe tog st = ~requested:st.installed Query -let simulate_new_state tog st universe install names = - match OpamSolver.resolve universe +let simulate_new_state ~task_pool tog st universe install names = + match OpamSolver.resolve ~task_pool universe (OpamSolver.request ~install ()) with | Success solution -> let new_st = OpamSolution.dry_run st solution in print_solution st new_st names solution; - new_st, get_universe tog new_st + new_st, get_universe ~task_pool tog new_st | Conflicts cs -> OpamConsole.error "Could not simulate installing the specified package(s) to this switch:"; @@ -403,7 +403,7 @@ let dry_install tog st universe install = simulate_new_state tog st universe install (OpamPackage.Name.Set.of_list (List.map fst install)) -let run st tog ?no_constraint mode filter atoms = +let run ~task_pool st tog ?no_constraint mode filter atoms = let open OpamPackage.Set.Op in let select, missing = List.fold_left (fun (select, missing) atom -> @@ -416,11 +416,11 @@ let run st tog ?no_constraint mode filter atoms = (OpamPackage.Set.empty, []) atoms in let st, universe = - let universe = get_universe tog st in + let universe = get_universe ~task_pool tog st in match mode, filter, missing with | Deps, _, [] -> st, universe | Deps, Roots_from, _::_ -> - dry_install tog st universe missing + dry_install ~task_pool tog st universe missing | Deps, Leads_to, _::_ | ReverseDeps, _, _ -> (* non-installed names don't make sense in rev-deps *) @@ -439,7 +439,7 @@ let run st tog ?no_constraint mode filter atoms = else let simulated = OpamFormula.packages_of_atoms st.installed missing in let forest = - build st universe tog mode filter (select ++ simulated) + build ~task_pool st universe tog mode filter (select ++ simulated) in print ?no_constraint forest; if OpamClientConfig.(!r.json_out) <> None then diff --git a/src/client/opamTreeCommand.mli b/src/client/opamTreeCommand.mli index b94c0d2a278..e685f897438 100644 --- a/src/client/opamTreeCommand.mli +++ b/src/client/opamTreeCommand.mli @@ -29,6 +29,7 @@ val duplicate_symbol: string (** Outputs a dependency forest of the installed packages as a Unicode/ASCII-art tree. *) val run : + task_pool:Domainslib.Task.pool -> [< unlocked > `Lock_write ] switch_state -> (* package selection options *) OpamListCommand.dependency_toggles -> diff --git a/src/core/dune b/src/core/dune index 226611716d8..d305fca82f8 100644 --- a/src/core/dune +++ b/src/core/dune @@ -3,7 +3,7 @@ (public_name opam-core) (synopsis "OCaml Package Manager core internal stdlib") ; TODO: Remove (re_export ...) when CI uses the OCaml version that includes https://github.com/ocaml/ocaml/pull/11989 - (libraries re (re_export ocamlgraph) unix sha jsonm swhid_core uutf + (libraries re (re_export ocamlgraph) unix sha jsonm swhid_core uutf domainslib (select opamACL.ml from (opam-core.libacl -> opamACL.libacl.ml) ( -> opamACL.dummy.ml)) diff --git a/src/core/opamCompat.ml b/src/core/opamCompat.ml index 216376563aa..d09c5af6626 100644 --- a/src/core/opamCompat.ml +++ b/src/core/opamCompat.ml @@ -48,16 +48,6 @@ module Unix = struct include Unix end -module Lazy = struct - [@@@warning "-32"] - - (** NOTE: OCaml >= 4.13 *) - let map f x = - lazy (f (Lazy.force x)) - - include Stdlib.Lazy -end - module Filename = struct [@@@warning "-32"] diff --git a/src/core/opamCompat.mli b/src/core/opamCompat.mli index 9596aedbb82..d74e4dd93e9 100644 --- a/src/core/opamCompat.mli +++ b/src/core/opamCompat.mli @@ -20,11 +20,6 @@ module Either : sig | Right of 'b end -module Lazy : sig - (* NOTE: OCaml >= 4.13 *) - val map : ('a -> 'b) -> 'a Lazy.t -> 'b Lazy.t -end - module Unix : sig (* `realpath` for OCaml >= 4.13.0, implementation with double chdir otherwise *) diff --git a/src/core/opamConsole.ml b/src/core/opamConsole.ml index bbc19c35a56..de1b228e370 100644 --- a/src/core/opamConsole.ml +++ b/src/core/opamConsole.ml @@ -15,7 +15,7 @@ let debug () = abs OpamCoreConfig.(!r.debug_level) > 0 let verbose () = OpamCoreConfig.(!r.verbose_level) > 0 -let dumb_term = lazy ( +let dumb_term = OpamLazy.create (fun () -> try OpamStd.Env.get "TERM" = "dumb" with Not_found -> @@ -23,28 +23,28 @@ let dumb_term = lazy ( ) let color = - let auto = lazy ( - OpamStd.Sys.tty_out && not (Lazy.force dumb_term) + let auto = OpamLazy.create (fun () -> + OpamStd.Sys.tty_out && not (OpamLazy.force dumb_term) ) in fun () -> match OpamCoreConfig.(!r.color) with | `Always -> true | `Never -> false - | `Auto -> Lazy.force auto + | `Auto -> OpamLazy.force auto let disp_status_line () = match OpamCoreConfig.(!r.disp_status_line) with | `Always -> true | `Never -> false - | `Auto -> OpamStd.Sys.tty_out && (color () || not (Lazy.force dumb_term)) + | `Auto -> OpamStd.Sys.tty_out && (color () || not (OpamLazy.force dumb_term)) let utf8, utf8_extended = - let use_auto_utf8_extended = lazy ( + let use_auto_utf8_extended = OpamLazy.create (fun () -> match OpamStd.Sys.os () with | Darwin -> true | Win32 -> OpamStubs.getConsoleWindowClass () <> Some "ConsoleWindowClass" | _ -> false ) in - let auto = lazy ( + let auto = OpamLazy.create (fun () -> if Sys.win32 then let attempt handle = let (info : OpamStubs.console_font_infoex) = @@ -77,11 +77,11 @@ let utf8, utf8_extended = (fun () -> match OpamCoreConfig.(!r.utf8) with | `Always | `Extended -> true | `Never -> false - | `Auto -> Lazy.force auto), + | `Auto -> OpamLazy.force auto), (fun () -> match OpamCoreConfig.(!r.utf8) with | `Extended -> true | `Always | `Never -> false - | `Auto -> Lazy.force auto && Lazy.force use_auto_utf8_extended) + | `Auto -> OpamLazy.force auto && OpamLazy.force use_auto_utf8_extended) module Symbols = struct let rightwards_arrow = Uchar.of_int 0x2192 @@ -140,18 +140,19 @@ let utf8_symbol main ?(alternates=[]) s = in let checker = let new_checker = - lazy {font = current_font; - checker = OpamStubs.create_glyph_checker current_font; - glyphs = Hashtbl.create 16} + OpamLazy.create (fun () -> + { font = current_font; + checker = OpamStubs.create_glyph_checker current_font; + glyphs = Hashtbl.create 16 }) in match win32_glyph_checker with | {contents = Some {font; checker; _}} when font <> current_font -> OpamStubs.delete_glyph_checker checker; - let checker = Lazy.force new_checker in + let checker = OpamLazy.force new_checker in win32_glyph_checker := Some checker; checker | {contents = None} -> - let checker = Lazy.force new_checker in + let checker = OpamLazy.force new_checker in win32_glyph_checker := Some checker; checker | {contents = Some checker} -> @@ -281,20 +282,20 @@ let enable_win32_vt100 ch = with Not_found -> (ch, VT100 ignore) -let stdout_state = lazy (enable_win32_vt100 OpamStubs.STD_OUTPUT_HANDLE) -let stderr_state = lazy (enable_win32_vt100 OpamStubs.STD_ERROR_HANDLE) +let stdout_state = OpamLazy.create (fun () -> enable_win32_vt100 OpamStubs.STD_OUTPUT_HANDLE) +let stderr_state = OpamLazy.create (fun () -> enable_win32_vt100 OpamStubs.STD_ERROR_HANDLE) let get_win32_console_shim : type s . [ `stdout | `stderr ] -> s shim_return -> s = fun ch -> let ch = if ch = `stdout then stdout_state else stderr_state in function | Handle -> - Lazy.force ch + OpamLazy.force ch | Mode -> - Lazy.force ch |> snd + OpamLazy.force ch |> snd | Peek -> - if Lazy.is_val ch then - match Lazy.force ch with + if OpamLazy.is_val ch then + match OpamLazy.force ch with | (_, Shim) -> false | (_, VT100 force) -> force (); true else @@ -322,7 +323,7 @@ let get_win32_console_shim : *) let is_windows_10 = - lazy (let (v, _, _, _) = OpamStubs.getWindowsVersion () in v >= 10) + OpamLazy.create (fun () -> let (v, _, _, _) = OpamStubs.getWindowsVersion () in v >= 10) let win32_print_message ch msg = let ocaml_ch = @@ -375,7 +376,7 @@ let win32_print_message ch msg = blend ~inheritbold:false (!color lor 0b1000) | "4" | "04" -> - if Lazy.force is_windows_10 then + if OpamLazy.force is_windows_10 then attributes lor 0b1000000000000000 else (* Don't have underline, so change the background *) @@ -453,7 +454,7 @@ let carriage_delete_windows () = let carriage_delete = if not OpamStd.Sys.tty_out then fun () -> () else if Sys.win32 then - let carriage_delete = lazy ( + let carriage_delete = OpamLazy.create (fun () -> match get_win32_console_shim `stdout Mode with | Shim -> carriage_delete_windows @@ -462,7 +463,7 @@ let carriage_delete = force (); carriage_delete_unix ()) in - fun () -> Lazy.force carriage_delete () + fun () -> OpamLazy.force carriage_delete () else carriage_delete_unix @@ -475,12 +476,12 @@ let rollback_terminal nlines = let left_1_char = let left_1_char_unix () = Printf.printf "\027[D%!" in if Sys.win32 then - let f = lazy ( + let f = OpamLazy.create (fun () -> match get_win32_console_shim `stdout Mode with | Shim -> fun () -> () (* unimplemented *) | VT100 force -> fun () -> force (); left_1_char_unix () ) in - fun () -> Lazy.force f () + fun () -> OpamLazy.force f () else left_1_char_unix let displaying_status = ref false @@ -493,7 +494,7 @@ let clear_status_unix () = let clear_status = if Sys.win32 then - let clear_status = lazy ( + let clear_status = OpamLazy.create (fun () -> match get_win32_console_shim `stdout Mode with | Shim -> fun () -> @@ -505,7 +506,7 @@ let clear_status = clear_status_unix ()) in fun () -> - Lazy.force clear_status () + OpamLazy.force clear_status () else clear_status_unix @@ -644,7 +645,7 @@ let write_status_windows fmt = in Printf.ksprintf print_string fmt -let win32_print_functions = lazy ( +let win32_print_functions = OpamLazy.create (fun () -> match get_win32_console_shim `stdout Mode with | Shim -> (true, (fun s -> win32_print_message `stdout (s ^ "\n")), print_string) @@ -656,7 +657,7 @@ let status_line fmt = debug () || not (disp_status_line ()) in let (use_shim, print_msg, print_string) = if Sys.win32 then - Lazy.force win32_print_functions + OpamLazy.force win32_print_functions else (false, print_endline, print_string) in diff --git a/src/core/opamCoreConfig.ml b/src/core/opamCoreConfig.ml index bfbd3b3cea8..1454085c258 100644 --- a/src/core/opamCoreConfig.ml +++ b/src/core/opamCoreConfig.ml @@ -202,8 +202,8 @@ let answer () = | _ -> `ask let answer_is = - let answer = lazy (answer ()) in - fun a -> Lazy.force answer = a + let answer = OpamLazy.create (fun () -> answer ()) in + fun a -> OpamLazy.force answer = a let answer_is_yes () = match answer () with diff --git a/src/core/opamLazy.ml b/src/core/opamLazy.ml new file mode 100644 index 00000000000..a6998dfeabd --- /dev/null +++ b/src/core/opamLazy.ml @@ -0,0 +1,42 @@ +type 'a t = { + l : 'a Lazy.t; + m : Mutex.t; +} + +let create f = + let l = lazy (f ()) in + let m = Mutex.create () in + { l; m } + +let from_fun = create + +external reraise : exn -> 'a = "%reraise" + +let force t = + let open Mutex in + lock t.m; + match Lazy.force t.l with + | x -> + unlock t.m; + x + | exception e -> + unlock t.m; + reraise e + +let from_val x = + let l = Lazy.from_val x in + let m = Mutex.create () in + { l; m } + +let map f x = + create (fun () -> f (force x)) + +let is_val t = + Mutex.lock t.m; + let res = Lazy.is_val t.l in + Mutex.unlock t.m; + res + +let memo_unit f = + let t = create f in + fun () -> force t diff --git a/src/core/opamLazy.mli b/src/core/opamLazy.mli new file mode 100644 index 00000000000..22c5e782587 --- /dev/null +++ b/src/core/opamLazy.mli @@ -0,0 +1,23 @@ +(* OpamLazy is a mutex protected thread-safe form of Lazy. *) +type 'a t + +(* [create f] is equivalent to [lazy (f ())]. *) +val create : (unit -> 'a) -> 'a t + +(* Same as create. *) +val from_fun : (unit -> 'a) -> 'a t + +(* [force t] is equivalent to [Lazy.force t]. *) +val force : 'a t -> 'a + +(* Identical to [Lazy.from_val]. *) +val from_val : 'a -> 'a t + +(* Equivalent to [OpamLazy.create (fun () -> f (OpamLazy.force x))] *) +val map : ('a -> 'b) -> 'a t -> 'b t + +(* [is_val t] returns true if t has already been forced and did not raise an exception. *) +val is_val : 'a t -> bool + +(* Equivalent to [let t = create f in fun () -> force f] *) +val memo_unit : (unit -> 'a) -> (unit -> 'a) diff --git a/src/core/opamProcess.ml b/src/core/opamProcess.ml index fb363b3593c..01b1ecb6180 100644 --- a/src/core/opamProcess.ml +++ b/src/core/opamProcess.ml @@ -13,12 +13,12 @@ let log ?level fmt = OpamConsole.log "PROC" ?level fmt let default_env = - let f () = lazy ( + let f () = OpamLazy.create (fun () -> match OpamCoreConfig.(!r.cygbin) with | Some cygbin -> OpamStd.Env.cyg_env ~cygbin ~git_location:OpamCoreConfig.(!r.git_location) | None -> OpamStd.Env.raw_env () ) in - fun () -> Lazy.force (f ()) + fun () -> OpamLazy.force (f ()) let cygwin_create_process_env prog args env fd1 fd2 fd3 = (* @@ -607,9 +607,9 @@ let verbose_print_cmd p = else Printf.sprintf " (CWD=%s)" p.p_cwd) let verbose_print_out = - let pfx = lazy (OpamConsole.colorise `yellow "- ") in + let pfx = OpamLazy.create (fun () ->OpamConsole.colorise `yellow "- ") in fun s -> - OpamConsole.msg "%s%s\n" (Lazy.force pfx) s + OpamConsole.msg "%s%s\n" (OpamLazy.force pfx) s (** Semi-synchronous printing of the output of a command *) let set_verbose_f, print_verbose_f, isset_verbose_f, stop_verbose_f = diff --git a/src/core/opamStd.ml b/src/core/opamStd.ml index 06c184b8894..9cd95739f8e 100644 --- a/src/core/opamStd.ml +++ b/src/core/opamStd.ml @@ -9,6 +9,8 @@ (* *) (**************************************************************************) +open Domainslib + module type SET = sig include Set.S val map: (elt -> elt) -> t -> t @@ -24,6 +26,7 @@ module type SET = sig val find_opt: (elt -> bool) -> t -> elt option val safe_add: elt -> t -> t val fixpoint: (elt -> t) -> t -> t + val parallel_fixpoint: task_pool:Domainslib.Task.pool -> (elt -> t) -> t -> t val map_reduce: ?default:'a -> (elt -> 'a) -> ('a -> 'a -> 'a) -> t -> 'a module Op : sig @@ -320,6 +323,28 @@ module Set = struct in aux empty + let parallel_fixpoint ~task_pool f = + let open Op in + + let rec aux fullset curset = + if is_empty curset then fullset else + let newset = + let size = S.cardinal curset in + let input = Array.make size (S.choose curset) in + let output = Array.make size empty in + let i = ref 0 in + S.iter (fun nv -> input.(!i) <- nv; incr i) curset; + Task.parallel_for task_pool ~start:0 ~finish:(size - 1) ~body:(fun i -> + output.(i) <- f input.(i)); + let newset = ref empty in + Array.iter (fun res -> newset := res ++ !newset) output; + !newset + in + let fullset = fullset ++ curset in + aux fullset (newset -- fullset) + in + aux empty + let map_reduce ?default f op t = match choose_opt t with | Some x -> @@ -834,8 +859,7 @@ module Env = struct let raw_env = Unix.environment let list = - let lazy_env = lazy (to_list (raw_env ())) in - fun () -> Lazy.force lazy_env + OpamLazy.memo_unit (fun () -> to_list (raw_env ())) let cyg_env ~cygbin ~git_location = let env = raw_env () in @@ -918,15 +942,15 @@ module OpamSys = struct let tty_in = Unix.isatty Unix.stdin - let default_columns = lazy ( - let default = 16_000_000 in - let cols = - try int_of_string (Env.get "COLUMNS") with - | Not_found - | Failure _ -> default - in - if cols > 0 then cols else default - ) + let default_columns = + OpamLazy.create (fun () -> + let default = 16_000_000 in + let cols = + try int_of_string (Env.get "COLUMNS") with + | Not_found + | Failure _ -> default + in + if cols > 0 then cols else default) let get_terminal_columns () = let fallback = 80 in @@ -956,14 +980,14 @@ module OpamSys = struct in width with Not_found -> - Lazy.force default_columns + OpamLazy.force default_columns let terminal_columns = - let v = ref (lazy (get_terminal_columns ())) in + let v = ref (OpamLazy.create (fun () -> get_terminal_columns ())) in let () = try Sys.set_signal 28 (* SIGWINCH *) (Sys.Signal_handle - (fun _ -> v := lazy (get_terminal_columns ()))) + (fun _ -> v := OpamLazy.create (fun () -> get_terminal_columns ()))) with Invalid_argument _ -> () in if Sys.win32 then @@ -972,24 +996,22 @@ module OpamSys = struct else fun () -> if tty_out - then Lazy.force !v - else Lazy.force default_columns + then OpamLazy.force !v + else OpamLazy.force default_columns let home = (* Note: we ask Unix.getenv instead of Env.get to avoid forcing the environment in this function that is used before the .init() functions are called -- see OpamStateConfig.default. *) - let home = lazy ( - try Unix.getenv "HOME" - with Not_found -> - if Sys.win32 then - (* CSIDL_PROFILE = 0x28 *) - OpamStubs.(shGetFolderPath 0x28 SHGFP_TYPE_CURRENT) - else - Sys.getcwd () - ) in - fun () -> Lazy.force home + OpamLazy.memo_unit (fun () -> + try Unix.getenv "HOME" + with Not_found -> + if Sys.win32 then + (* CSIDL_PROFILE = 0x28 *) + OpamStubs.(shGetFolderPath 0x28 SHGFP_TYPE_CURRENT) + else + Sys.getcwd ()) let etc () = "/etc" @@ -1023,7 +1045,7 @@ module OpamSys = struct | Other of string let os = - let os = lazy ( + OpamLazy.memo_unit (fun () -> match Sys.os_type with | "Unix" -> begin match uname "-s" with @@ -1037,9 +1059,7 @@ module OpamSys = struct end | "Win32" -> Win32 | "Cygwin" -> Cygwin - | s -> Other s - ) in - fun () -> Lazy.force os + | s -> Other s) type powershell_host = Powershell_pwsh | Powershell type shell = SH_sh | SH_bash | SH_zsh | SH_csh | SH_fish @@ -1082,7 +1102,7 @@ module OpamSys = struct let chop_exe_suffix name = Option.default name (Filename.chop_suffix_opt name ~suffix:".exe") - let windows_process_ancestry = Lazy.from_fun OpamStubs.getProcessAncestry + let windows_process_ancestry = OpamLazy.from_fun OpamStubs.getProcessAncestry type shell_choice = Accept of shell @@ -1099,12 +1119,11 @@ module OpamSys = struct (fun shell -> Accept shell) (shell_of_string (chop_exe_suffix name)) in - lazy ( - let lazy ancestors = windows_process_ancestry in + OpamLazy.create (fun () -> + let ancestors = OpamLazy.force windows_process_ancestry in match OpamList.filter_map categorize_process ancestors with | [] -> None - | Accept most_relevant_shell :: _ -> Some most_relevant_shell - ) + | Accept most_relevant_shell :: _ -> Some most_relevant_shell) let guess_shell_compat () = let parent_guess () = @@ -1139,7 +1158,7 @@ module OpamSys = struct let test shell = shell_of_string (Filename.basename shell) in if Sys.win32 then let shell = - match Lazy.force windows_get_shell with + match OpamLazy.force windows_get_shell with | None -> Option.of_Not_found Env.get "SHELL" |> Option.replace test | some -> @@ -1349,18 +1368,18 @@ module Win32 = struct end let (set_parent_pid, parent_putenv) = - let ppid = ref (OpamCompat.Lazy.map (function (_::(pid, _)::_) -> pid | _ -> 0l) OpamSys.windows_process_ancestry) in - let parent_putenv = lazy ( - let {contents = lazy ppid} = ppid in + let ppid = ref (OpamLazy.map (function (_::(pid, _)::_) -> pid | _ -> 0l) OpamSys.windows_process_ancestry) in + let parent_putenv = OpamLazy.create (fun () -> + let ppid = OpamLazy.force !ppid in let our_architecture = OpamStubs.getProcessArchitecture None in let their_architecture = OpamStubs.getProcessArchitecture (Some ppid) in let no_opam_putenv = - let warning = lazy ( + let warning = OpamLazy.create (fun () -> !console.warning "opam-putenv was not found - \ OPAM is unable to alter environment variables"; false) in - fun _ _ -> Lazy.force warning + fun _ _ -> OpamLazy.force warning in if our_architecture <> their_architecture then match their_architecture with @@ -1406,10 +1425,10 @@ module Win32 = struct | key -> OpamStubs.process_putenv ppid key) in ((fun pid -> - if Lazy.is_val parent_putenv then + if OpamLazy.is_val parent_putenv then failwith "Target parent already known"; - ppid := Lazy.from_val pid), - (fun key -> (Lazy.force parent_putenv) key)) + ppid := OpamLazy.from_val pid), + (fun key -> (OpamLazy.force parent_putenv) key)) let persistHomeDirectory dir = (* Update our environment *) @@ -1739,7 +1758,7 @@ module Config = struct let resolve_when ~auto = function | `Always -> true | `Never -> false - | `Auto -> Lazy.force auto + | `Auto -> OpamLazy.force auto let answer s = match String.lowercase_ascii s with @@ -1766,8 +1785,7 @@ module Config = struct let find var = OpamList.find_map var !r let value_t var = try Some (find var) with Not_found -> None let value var = - let l = lazy (value_t var) in - fun () -> Lazy.force l + OpamLazy.memo_unit (fun () -> value_t var) end end diff --git a/src/core/opamStd.mli b/src/core/opamStd.mli index a136451adfa..1a59c17e28e 100644 --- a/src/core/opamStd.mli +++ b/src/core/opamStd.mli @@ -42,6 +42,7 @@ module type SET = sig (** Accumulates the resulting sets of a function of elements until a fixpoint is reached *) val fixpoint: (elt -> t) -> t -> t + val parallel_fixpoint: task_pool:Domainslib.Task.pool -> (elt -> t) -> t -> t (** [map_reduce f op t] applies [f] to every element of [t] and combines the results using associative operator [op]. Raises [Invalid_argument] on an @@ -678,7 +679,7 @@ module Config : sig val env_when_ext: env_var -> when_ext option - val resolve_when: auto:(bool Lazy.t) -> when_ -> bool + val resolve_when: auto:(bool OpamLazy.t) -> when_ -> bool val env_answer: env_var -> answer option @@ -725,7 +726,7 @@ module Config : sig type t = .. type t += REMOVED val find: (t -> 'a option) -> 'a - (* Lazy *) + (* OpamLazy *) val value: (t -> 'a option) -> (unit -> 'a option) (* Not lazy *) val value_t: (t -> 'a option) -> 'a option diff --git a/src/core/opamSystem.ml b/src/core/opamSystem.ml index cd4169ccd9d..5cc0bfe337f 100644 --- a/src/core/opamSystem.ml +++ b/src/core/opamSystem.ml @@ -541,7 +541,7 @@ let apply_cygpath name = let get_cygpath_function = if Sys.win32 then fun ~command -> - lazy ( + OpamLazy.create (fun () -> if OpamStd.Option.map_default (OpamStd.Sys.is_cygwin_variant ~cygbin:(OpamCoreConfig.(!r.cygbin))) @@ -551,7 +551,7 @@ let get_cygpath_function = else fun x -> x ) else - let f = Lazy.from_val (fun x -> x) in + let f = OpamLazy.from_val (fun x -> x) in fun ~command:_ -> f let apply_cygpath_path_transform ~pathlist cygpath path = @@ -571,12 +571,12 @@ let get_cygpath_path_transform = (* We are running in a functioning Cygwin or MSYS2 environment if and only if `cygpath` is in the PATH. *) if Sys.win32 then - lazy ( + OpamLazy.create (fun () -> match resolve_command "cygpath" with | Some cygpath -> apply_cygpath_path_transform cygpath | None -> fun ~pathlist:_ x -> x) else - Lazy.from_val (fun ~pathlist:_ x -> x) + OpamLazy.from_val (fun ~pathlist:_ x -> x) let runs = ref [] let print_stats () = @@ -912,6 +912,9 @@ let cpu_count () = int_of_string (List.hd ans) with Not_found | Process_error _ | Failure _ -> 1 +let cpu_count_memo = + OpamLazy.memo_unit cpu_count + open OpamProcess.Job.Op module Tar = struct @@ -984,22 +987,22 @@ module Tar = struct Some (Printf.sprintf "Tar needs %s to extract the archive" cmd) else None) - let tar_cmd = lazy ( + let tar_cmd = OpamLazy.create (fun () -> match OpamStd.Sys.os () with | OpamStd.Sys.OpenBSD -> "gtar" | _ -> "tar" ) - let cygpath_tar = lazy ( - Lazy.force (get_cygpath_function ~command:(Lazy.force tar_cmd)) + let cygpath_tar = OpamLazy.create (fun () -> + OpamLazy.force (get_cygpath_function ~command:(OpamLazy.force tar_cmd)) ) let extract_command = fun file -> OpamStd.Option.Op.( get_type file >>| fun typ -> - let f = Lazy.force cygpath_tar in - let tar_cmd = Lazy.force tar_cmd in + let f = OpamLazy.force cygpath_tar in + let tar_cmd = OpamLazy.force tar_cmd in let command c dir = make_command tar_cmd [ Printf.sprintf "xf%c" c ; f file; "-C" ; f dir ] in @@ -1007,8 +1010,8 @@ module Tar = struct let compress_command = fun file dir -> - let f = Lazy.force cygpath_tar in - let tar_cmd = Lazy.force tar_cmd in + let f = OpamLazy.force cygpath_tar in + let tar_cmd = OpamLazy.force tar_cmd in make_command tar_cmd [ "cfz"; f file; "-C" ; f (Filename.dirname dir); diff --git a/src/core/opamSystem.mli b/src/core/opamSystem.mli index de977c51c0d..53f9d588747 100644 --- a/src/core/opamSystem.mli +++ b/src/core/opamSystem.mli @@ -190,7 +190,7 @@ val bin_contains_bash: string -> bool (** Returns a function which should be applied to arguments for a given command by determining if the command is the Cygwin variant of the command. Returns the identity function otherwise. *) -val get_cygpath_function: command:string -> (string -> string) lazy_t +val get_cygpath_function: command:string -> (string -> string) OpamLazy.t (** Returns a function which should be applied to a path (or a path list), if in a functioning Cygwin or MSYS2 environment, translating the Windows or a @@ -199,7 +199,7 @@ val get_cygpath_function: command:string -> (string -> string) lazy_t otherwise. [pathlist] argument permit to specify if it is applied to a path or a path list, by giving the `--path` argument in the last case. *) -val get_cygpath_path_transform: (pathlist:bool -> string -> string) lazy_t +val get_cygpath_path_transform: (pathlist:bool -> string -> string) OpamLazy.t (** [apply_cygpath path] applies the `cygpath` command to [name] using `cygpath -- name`. *) @@ -256,6 +256,9 @@ val mkdir: string -> unit (** Get the number of active processors on the system *) val cpu_count: unit -> int +(** Get the number of active processors on the system, but memoizes the answer. *) +val cpu_count_memo: unit -> int + (** {2 File locking function} *) (** Unix file locks (mutable structure, to follow actual semantics) *) diff --git a/src/format/dune b/src/format/dune index 975870b1e82..0bc6c98b856 100644 --- a/src/format/dune +++ b/src/format/dune @@ -3,7 +3,7 @@ (public_name opam-format) (synopsis "OCaml Package Manager file format handling library") ; TODO: Remove (re_export ...) when CI uses the OCaml version that includes https://github.com/ocaml/ocaml/pull/11989 - (libraries (re_export opam-core) (re_export opam-file-format) re) + (libraries (re_export opam-core) (re_export opam-file-format) re domainslib) (modules_without_implementation OpamTypes) (flags (:standard (:include ../ocaml-flags-standard.sexp) diff --git a/src/format/opamFormula.ml b/src/format/opamFormula.ml index 6931055e492..5537af03ae1 100644 --- a/src/format/opamFormula.ml +++ b/src/format/opamFormula.ml @@ -145,6 +145,8 @@ let rec map f = function | Empty -> Empty | x -> Block x +(* Offer a parallel_map ~task_pool perhaps? *) + (* Maps top-down *) let rec map_formula f t = let t = f t in diff --git a/src/format/opamFormula.mli b/src/format/opamFormula.mli index 07bf7216b06..d73f8df650b 100644 --- a/src/format/opamFormula.mli +++ b/src/format/opamFormula.mli @@ -117,6 +117,10 @@ val ors_to_list: 'a formula -> 'a formula list will be simply removed *) val map: ('a -> 'b formula) -> 'a formula -> 'b formula +(** Map on atoms. Atoms for which the given function returns Empty + will be simply removed *) +(*val parallel_map: ?depth:int -> task_pool:Domainslib.Task.pool -> ('a -> 'b formula) -> 'a formula -> 'b formula*) + (** Maps top-down on a formula *) val map_formula: ('a formula -> 'a formula) -> 'a formula -> 'a formula diff --git a/src/format/opamPackage.ml b/src/format/opamPackage.ml index f9b3d93c852..b096a88f9ef 100644 --- a/src/format/opamPackage.ml +++ b/src/format/opamPackage.ml @@ -104,7 +104,6 @@ module Name = struct module Set = OpamStd.Set.Make(O) module Map = OpamStd.Map.Make(O) - end type t = { diff --git a/src/format/opamPath.ml b/src/format/opamPath.ml index cefd503cc2b..d7acec33666 100644 --- a/src/format/opamPath.ml +++ b/src/format/opamPath.ml @@ -49,12 +49,10 @@ let hooks_dir t = init t / "hooks" let log t = t / "log" let backup_file = - let file = lazy Unix.( - let tm = gmtime (Unix.gettimeofday ()) in - Printf.sprintf "state-%04d%02d%02d%02d%02d%02d.export" - (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec - ) in - fun () -> Lazy.force file + OpamLazy.memo_unit (fun () -> + let tm = Unix.gmtime (Unix.gettimeofday ()) in + Printf.sprintf "state-%04d%02d%02d%02d%02d%02d.export" + (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec) let backup_dir t = t / "backup" diff --git a/src/repository/opamDownload.ml b/src/repository/opamDownload.ml index f67e7a827ba..dab863ee127 100644 --- a/src/repository/opamDownload.ml +++ b/src/repository/opamDownload.ml @@ -58,7 +58,7 @@ let ftp_args = [ ] let download_args ~url ~out ~retry ?checksum ~compress () = - let cmd, _ = Lazy.force OpamRepositoryConfig.(!r.download_tool) in + let cmd, _ = OpamLazy.force OpamRepositoryConfig.(!r.download_tool) in let cmd = match cmd with | [(CIdent "wget"), _] -> cmd @ wget_args @@ -91,7 +91,7 @@ let download_args ~url ~out ~retry ?checksum ~compress () = cmd let tool_return url ret = - match Lazy.force OpamRepositoryConfig.(!r.download_tool) with + match OpamLazy.force OpamRepositoryConfig.(!r.download_tool) with | _, `Default -> if OpamProcess.is_failure ret then fail (Some "Download command failed", @@ -199,7 +199,7 @@ let download ?quiet ?validate ~overwrite ?compress ?checksum url dstdir = let post_tools = ["wget"; "curl"] let check_post_tool () = - match Lazy.force OpamRepositoryConfig.(!r.download_tool) with + match OpamLazy.force OpamRepositoryConfig.(!r.download_tool) with | [(CIdent cmd), _], _ -> List.mem cmd post_tools | _ -> false diff --git a/src/repository/opamGit.ml b/src/repository/opamGit.ml index 03eba8aa2c6..f944ffbbb19 100644 --- a/src/repository/opamGit.ml +++ b/src/repository/opamGit.ml @@ -83,7 +83,7 @@ module VCS : OpamVCS.VCS = struct else Done (Some dir) | _ -> Done None) @@+ fun global_cache -> - let repo_url = OpamUrl.map_file_url (Lazy.force cygpath) repo_url in + let repo_url = OpamUrl.map_file_url (OpamLazy.force cygpath) repo_url in let origin = OpamUrl.base_url repo_url in let branch = OpamStd.Option.default "HEAD" repo_url.OpamUrl.hash in let opam_ref = remote_ref repo_url in diff --git a/src/repository/opamLocal.ml b/src/repository/opamLocal.ml index ab8baed757f..2f517db9db0 100644 --- a/src/repository/opamLocal.ml +++ b/src/repository/opamLocal.ml @@ -86,7 +86,7 @@ let rsync ?(args=[]) ?(exclude_vcdirs=true) src dst = Done (Not_available (None, src))) else ( OpamSystem.mkdir dst; - let convert_path = Lazy.force convert_path in + let convert_path = OpamLazy.force convert_path in call_rsync (fun () -> not (OpamSystem.dir_is_empty dst)) ( rsync_arg :: args @ exclude_args @ [ "--delete"; "--delete-excluded"; convert_path src; convert_path dst; ]) @@ -123,7 +123,7 @@ let rsync_file ?(args=[]) url dst = Done (Up_to_date dst) else (OpamFilename.mkdir (OpamFilename.dirname dst); - let convert_path = Lazy.force convert_path in + let convert_path = OpamLazy.force convert_path in call_rsync (fun () -> Sys.file_exists dst_s) ( rsync_arg :: args @ [ convert_path src_s; convert_path dst_s ]) @@| function diff --git a/src/repository/opamRepositoryConfig.ml b/src/repository/opamRepositoryConfig.ml index 306f3be8237..8a172633275 100644 --- a/src/repository/opamRepositoryConfig.ml +++ b/src/repository/opamRepositoryConfig.ml @@ -37,7 +37,7 @@ end type dl_tool_kind = [ `Curl | `Default ] type t = { - download_tool: (arg list * dl_tool_kind) Lazy.t; + download_tool: (arg list * dl_tool_kind) OpamLazy.t; validation_hook: arg list option; retries: int; force_checksums: bool option; @@ -45,7 +45,7 @@ type t = { } type 'a options_fun = - ?download_tool:(OpamTypes.arg list * dl_tool_kind) Lazy.t -> + ?download_tool:(OpamTypes.arg list * dl_tool_kind) OpamLazy.t -> ?validation_hook:arg list option -> ?retries:int -> ?force_checksums:bool option -> @@ -53,7 +53,7 @@ type 'a options_fun = 'a let default = { - download_tool = lazy ( + download_tool = OpamLazy.create (fun () -> let os = OpamStd.Sys.os () in try let curl = "curl", `Curl in @@ -128,13 +128,13 @@ let initk k = ) |> (fun fetch -> match E.curl (), fetch with - | None, fetch -> OpamStd.Option.map Lazy.from_val fetch + | None, fetch -> OpamStd.Option.map OpamLazy.from_val fetch | Some cmd, Some (((CIdent "curl"| CString "curl"), filter)::args, _) -> - Some (lazy ((CString cmd, filter)::args, `Curl)) + Some (OpamLazy.create (fun () ->(CString cmd, filter)::args, `Curl)) | Some cmd, None -> - Some (lazy ([CString cmd, None], `Curl)) + Some (OpamLazy.create (fun () ->[CString cmd, None], `Curl)) | Some _, _ -> (* ignored *) - OpamStd.Option.map Lazy.from_val fetch) + OpamStd.Option.map OpamLazy.from_val fetch) in let validation_hook = E.validationhook () >>| fun s -> diff --git a/src/repository/opamRepositoryConfig.mli b/src/repository/opamRepositoryConfig.mli index ddcdb9522a8..1ecdf513a3b 100644 --- a/src/repository/opamRepositoryConfig.mli +++ b/src/repository/opamRepositoryConfig.mli @@ -34,7 +34,7 @@ end type dl_tool_kind = [ `Curl | `Default ] type t = { - download_tool: (OpamTypes.arg list * dl_tool_kind) Lazy.t; + download_tool: (OpamTypes.arg list * dl_tool_kind) OpamLazy.t; validation_hook: OpamTypes.arg list option; retries: int; force_checksums: bool option; @@ -42,7 +42,7 @@ type t = { } type 'a options_fun = - ?download_tool:(OpamTypes.arg list * dl_tool_kind) Lazy.t -> + ?download_tool:(OpamTypes.arg list * dl_tool_kind) OpamLazy.t -> ?validation_hook:OpamTypes.arg list option -> ?retries:int -> ?force_checksums:bool option -> diff --git a/src/repository/opamRepositoryPath.ml b/src/repository/opamRepositoryPath.ml index ccc79df1bbb..089cefec7ca 100644 --- a/src/repository/opamRepositoryPath.ml +++ b/src/repository/opamRepositoryPath.ml @@ -18,11 +18,9 @@ let tar root name = root / "repo" // (OpamRepositoryName.to_string name ^ ".tar. let download_cache root = root / "download-cache" let pin_cache_dir = - let dir = - lazy (OpamSystem.mk_temp_dir ~prefix:"opam-pin-cache" () - |> OpamFilename.Dir.of_string ) - in - fun () -> Lazy.force dir + OpamLazy.memo_unit (fun () -> + OpamSystem.mk_temp_dir ~prefix:"opam-pin-cache" () + |> OpamFilename.Dir.of_string) let pin_cache u = pin_cache_dir () / diff --git a/src/repository/opamVCS.ml b/src/repository/opamVCS.ml index d46e8dbd364..edff41a4066 100644 --- a/src/repository/opamVCS.ml +++ b/src/repository/opamVCS.ml @@ -172,7 +172,7 @@ module Make (VCS: VCS) = struct f in let args = [ - "--files-from"; (Lazy.force convert_path) stdout_file; + "--files-from"; (OpamLazy.force convert_path) stdout_file; ] in OpamLocal.rsync_dirs ~args repo_url repo_root @@+ fun result -> OpamSystem.remove stdout_file; diff --git a/src/solver/dune b/src/solver/dune index 0e00b6a5f0f..f8f69e1468e 100644 --- a/src/solver/dune +++ b/src/solver/dune @@ -3,7 +3,8 @@ (public_name opam-solver) (synopsis "OCaml Package Manager solver interaction library") ; TODO: Remove (re_export ...) when CI uses the OCaml version that includes https://github.com/ocaml/ocaml/pull/11989 - (libraries (re_export opam-format) (re_export cudf) (re_export dose3.common) (re_export dose3.algo) re opam-0install-cudf + (libraries (re_export opam-format) (re_export cudf) (re_export dose3.common) (re_export dose3.algo) + re opam-0install-cudf (select opamBuiltinMccs.ml from (mccs -> opamBuiltinMccs.real.ml) ( -> opamBuiltinMccs.dummy.ml)) diff --git a/src/solver/opamCudf.ml b/src/solver/opamCudf.ml index 9f6f8390ef8..b13fc672d06 100644 --- a/src/solver/opamCudf.ml +++ b/src/solver/opamCudf.ml @@ -11,6 +11,7 @@ open OpamTypes open OpamTypesBase +open Domainslib let log ?level fmt = OpamConsole.log ?level "CUDF" fmt let slog = OpamConsole.slog @@ -1249,7 +1250,7 @@ let dump_cudf_request ~version_map (_, univ,_ as cudf) criteria = incr solver_calls; let filename = Printf.sprintf "%s-%d.cudf" f !solver_calls in let oc = open_out filename in - let module Solver = (val OpamSolverConfig.(Lazy.force !r.solver)) in + let module Solver = (val OpamSolverConfig.(OpamLazy.force !r.solver)) in Printf.fprintf oc "# Solver: %s\n" (OpamCudfSolver.get_name (module Solver)); Printf.fprintf oc "# Criteria: %s\n" criteria; @@ -1345,10 +1346,10 @@ let compute_conflicts univ packages = (to_map packages) Set.empty -let preprocess_cudf_request (props, univ, creq) criteria = +let preprocess_cudf_request ~task_pool (props, univ, creq) criteria = let chrono = OpamConsole.timer () in let univ0 = univ in - let do_trimming = + let do_trimming_prom = Task.async task_pool (fun () -> match OpamSolverConfig.(!r.cudf_trim) with | Some "simple" -> Some false | b -> @@ -1368,13 +1369,15 @@ let preprocess_cudf_request (props, univ, creq) criteria = neg_crit_re])) in Some (Re.execp (Re.compile all_neg_re) criteria) + ) in let univ = let open Set.Op in - let to_install = - vpkg2set univ creq.Cudf.install - ++ Set.of_list (Cudf.lookup_packages univ opam_invariant_package_name) - ++ Set.of_list (Cudf.lookup_packages univ opam_deprequest_package_name) + let to_install_prom = + Task.async task_pool (fun () -> + vpkg2set univ creq.Cudf.install + ++ Set.of_list (Cudf.lookup_packages univ opam_invariant_package_name) + ++ Set.of_list (Cudf.lookup_packages univ opam_deprequest_package_name)) in let to_install_formula = List.map (fun x -> [x]) @@ @@ -1382,8 +1385,8 @@ let preprocess_cudf_request (props, univ, creq) criteria = (opam_deprequest_package_name, None) :: creq.Cudf.install @ creq.Cudf.upgrade in - let packages = - match do_trimming with + let packages_prom = Task.async task_pool (fun () -> + match Task.await task_pool do_trimming_prom with | None -> Set.of_list (Cudf.get_packages univ) | Some false -> (* "simple" trimming *) @@ -1422,15 +1425,21 @@ let preprocess_cudf_request (props, univ, creq) criteria = not (OpamStd.String.Map.mem d.Cudf.package strong_deps_cone)) (dependency_set univ p.Cudf.depends)) interesting_set + ) in - let conflicts = compute_conflicts univ to_install in + let conflicts_prom = Task.async task_pool (fun () -> + let to_install = Task.await task_pool to_install_prom in + compute_conflicts univ to_install) + in + let packages = Task.await task_pool packages_prom in + let conflicts = Task.await task_pool conflicts_prom in log "Conflicts: %a (%a) pkgs to remove" (slog OpamStd.Op.(string_of_int @* Set.cardinal)) conflicts (slog OpamStd.Op.(string_of_int @* Set.cardinal)) (conflicts %% packages); Cudf.load_universe (Set.elements (packages -- conflicts)) in log "Preprocess cudf request (trimming: %s): from %d to %d packages in %.2fs" - (match do_trimming with + (match Task.await task_pool do_trimming_prom with None -> "none" | Some false -> "simple" | Some true -> "full") (Cudf.universe_size univ0) (Cudf.universe_size univ) @@ -1452,7 +1461,7 @@ let trim_universe univ packages = exception Timeout of Dose_algo.Depsolver.solver_result option -let call_external_solver ~version_map univ req = +let call_external_solver ~task_pool ~version_map univ req = let cudf_request = to_cudf univ req in if Cudf.universe_size univ > 0 then let criteria = OpamSolverConfig.criteria req.criteria in @@ -1468,14 +1477,14 @@ let call_external_solver ~version_map univ req = | OpamCudfSolver.Timeout None -> raise (Timeout None) in let r = - Dose_algo.Depsolver.check_request_using ~call_solver ~explain req + Dose_algo.Depsolver.check_request_using ~task_pool ~call_solver ~explain req in if !timed_out then raise (Timeout (Some r)) else r in try let cudf_request = if not OpamSolverConfig.(!r.preprocess) then cudf_request - else preprocess_cudf_request cudf_request criteria + else preprocess_cudf_request ~task_pool cudf_request criteria in let r = check_request_using @@ -1523,10 +1532,10 @@ let call_external_solver ~version_map univ req = else Dose_algo.Depsolver.Sat(None,Cudf.load_universe []) -let check_request ?(explain=true) ~version_map univ req = +let check_request ?(explain=true) ~task_pool ~version_map univ req = let chrono = OpamConsole.timer () in log "Checking request..."; - let result = Dose_algo.Depsolver.check_request ~explain (to_cudf univ req) in + let result = Dose_algo.Depsolver.check_request ~task_pool ~explain (to_cudf univ req) in log "Request checked in %.3fs" (chrono ()); match result with | Dose_algo.Depsolver.Unsat @@ -1545,7 +1554,7 @@ let check_request ?(explain=true) ~version_map univ req = conflict_empty ~version_map univ (* Return the universe in which the system has to go *) -let get_final_universe ~version_map univ req = +let get_final_universe ~task_pool ~version_map univ req = let fail msg = let f = dump_cudf_error ~version_map univ req in let msg = @@ -1553,7 +1562,7 @@ let get_final_universe ~version_map univ req = msg f in raise (Solver_failure msg) in - match call_external_solver ~version_map univ req with + match call_external_solver ~task_pool ~version_map univ req with | Dose_algo.Depsolver.Sat (_,u) -> Success (remove u dose_dummy_request None) | Dose_algo.Depsolver.Error "(CRASH) Solution file is empty" -> (* XXX Is this still needed with latest dose? *) @@ -1592,14 +1601,23 @@ let actions_of_diff (install, remove) = let actions = Set.fold (fun p acc -> `Remove p :: acc) remove actions in actions -let resolve ~extern ~version_map universe request = +let resolve ~task_pool ~extern ~version_map universe request = log "resolve request=%a" (slog string_of_request) request; let resp = - let check () = check_request ~version_map universe request in - let solve () = get_final_universe ~version_map universe request in - if not extern then check () else - let module Solver : OpamCudfSolver.S = - (val Lazy.force OpamSolverConfig.(!r.solver)) + (* XXX: may not need to run check () always *) + let check_prom = + Task.async task_pool (fun () -> + check_request ~task_pool ~version_map universe request) + in + let solve_prom = + Task.async task_pool (fun () -> + get_final_universe ~task_pool ~version_map universe request) + in + let check () = Task.await task_pool check_prom in + let solve () = Task.await task_pool solve_prom in + if not extern + then check () else + let module Solver : OpamCudfSolver.S = (val OpamLazy.force OpamSolverConfig.(!r.solver)) in let wrong_unsat_msg = Printf.sprintf diff --git a/src/solver/opamCudf.mli b/src/solver/opamCudf.mli index 278be48c1c3..6fe43f573aa 100644 --- a/src/solver/opamCudf.mli +++ b/src/solver/opamCudf.mli @@ -70,6 +70,7 @@ val trim_universe: Cudf.universe -> Set.t -> Cudf.universe [explain] is set to [false] *) val check_request: ?explain:bool -> + task_pool:Domainslib.Task.pool -> version_map:int OpamPackage.Map.t -> Cudf.universe -> Cudf_types.vpkg request -> @@ -77,6 +78,7 @@ val check_request: (** Compute the final universe state using the external solver. *) val get_final_universe: + task_pool:Domainslib.Task.pool -> version_map:int OpamPackage.Map.t -> Cudf.universe -> Cudf_types.vpkg request -> @@ -132,6 +134,7 @@ exception Solver_failure of string an explanation of the error, or a resulting universe. [~extern] specifies whether the external solver should be used *) val resolve: + task_pool:Domainslib.Task.pool -> extern:bool -> version_map:int OpamPackage.Map.t -> Cudf.universe -> diff --git a/src/solver/opamCudfSolver.ml b/src/solver/opamCudfSolver.ml index c60a0d012fe..e368401f629 100644 --- a/src/solver/opamCudfSolver.ml +++ b/src/solver/opamCudfSolver.ml @@ -21,7 +21,7 @@ let default_compat_criteria = { module type ExternalArg = sig val name: string - val is_present: bool Lazy.t + val is_present: bool OpamLazy.t val command_name: string val command_args: OpamTypes.arg list val default_criteria: criteria_def @@ -82,7 +82,7 @@ module External (E: ExternalArg) : S = struct let ext = ref None - let is_present () = Lazy.force E.is_present + let is_present () = OpamLazy.force E.is_present let command_name = Some E.command_name @@ -99,7 +99,7 @@ module Aspcud_def = struct let command_name = "aspcud" - let is_present = lazy ( + let is_present = OpamLazy.create (fun () -> match OpamSystem.resolve_command command_name with | None -> false | Some cmd -> @@ -155,7 +155,7 @@ module Aspcud_old_def = struct let command_name = Aspcud_def.command_name - let is_present = lazy (OpamSystem.resolve_command command_name <> None) + let is_present = OpamLazy.create (fun () -> OpamSystem.resolve_command command_name <> None) let command_args = Aspcud_def.command_args @@ -169,7 +169,7 @@ module Mccs_def = struct let command_name = "mccs" - let is_present = lazy (OpamSystem.resolve_command command_name <> None) + let is_present = OpamLazy.create (fun () -> OpamSystem.resolve_command command_name <> None) let command_args = [ CString "-i", None; CIdent "input", None; @@ -205,7 +205,7 @@ module Packup_def = struct let command_name = "packup" - let is_present = lazy (OpamSystem.resolve_command command_name <> None) + let is_present = OpamLazy.create (fun () -> OpamSystem.resolve_command command_name <> None) let command_args = [ CIdent "input", None; CIdent "output", None; @@ -222,7 +222,7 @@ let make_custom_solver name args criteria = (External (struct let command_name = name let name = name ^ "-custom" - let is_present = lazy true + let is_present = OpamLazy.from_val true let command_args = args let default_criteria = criteria end)) diff --git a/src/solver/opamSolver.ml b/src/solver/opamSolver.ml index bd68b18327f..ec91dbd62ce 100644 --- a/src/solver/opamSolver.ml +++ b/src/solver/opamSolver.ml @@ -13,6 +13,8 @@ open OpamTypes open OpamTypesBase open OpamPackage.Set.Op +open Domainslib + let log ?level fmt = OpamConsole.log ?level "SOLVER" fmt let slog = OpamConsole.slog @@ -41,8 +43,9 @@ let solution_to_json solution = let solution_of_json json = OpamCudf.ActionGraph.of_json json -let cudf_versions_map universe = +let cudf_versions_map ~task_pool:_ universe = log ~level:3 "cudf_versions_map"; + let chrono = OpamConsole.timer () in let add_packages_from_formula acc formula = List.fold_left (fun acc -> function | n, Some (_, v) -> OpamPackage.Set.add (OpamPackage.create n v) acc @@ -64,6 +67,7 @@ let cudf_versions_map universe = let packages = add_referred_to_packages id packages universe.u_conflicts in let packages = add_packages_from_formula packages universe.u_invariant in let pmap = OpamPackage.to_map packages in + let res = OpamPackage.Name.Map.fold (fun name versions acc -> let _, map = OpamPackage.Version.Set.fold @@ -73,6 +77,9 @@ let cudf_versions_map universe = versions (1,acc) in map) pmap OpamPackage.Map.empty + in + log ~level:3 "cudf_versions_map done: %.3f" (chrono ()); + res let name_to_cudf name = let name_s = OpamPackage.Name.to_string name in @@ -162,11 +169,14 @@ let lag_function = let rec power n x = if n <= 0 then 1 else x * power (n-1) x in power OpamSolverConfig.(!r.version_lag_power) -let opam2cudf_map universe version_map packages = +let opam2cudf_map ~task_pool universe version_map packages = + let chrono = OpamConsole.timer () in let set_to_bool_map set = OpamPackage.Set.fold (fun nv -> OpamPackage.Map.add nv true) (packages %% set) OpamPackage.Map.empty in + log ~level:3 "opam2cudf_map: Loading base_map: %.3fs" (chrono ()); + let chrono = OpamConsole.timer () in let base_map = OpamPackage.Set.fold (fun nv -> OpamPackage.Map.add nv @@ -179,11 +189,15 @@ let opam2cudf_map universe version_map packages = }) packages OpamPackage.Map.empty in + log ~level:3 "opam2cudf_map: Loaded base_map: %.3fs" (chrono ()); + let chrono = OpamConsole.timer () in let only_packages m = OpamPackage.Map.merge (fun _ -> function None -> fun _ -> None | Some _ -> fun x -> x) base_map m in + log ~level:3 "opam2cudf_map: only_packages done: %.3fs" (chrono ()); + let chrono = OpamConsole.timer () in let installed_map = set_to_bool_map universe.u_installed in let reinstall_map = set_to_bool_map universe.u_reinstall in let installed_root_map = set_to_bool_map universe.u_installed_roots in @@ -192,6 +206,8 @@ let opam2cudf_map universe version_map packages = OpamStd.Option.default OpamPackage.Set.empty @@ OpamStd.List.assoc_opt String.equal "avoid-version" universe.u_attrs in + log ~level:3 "opam2cudf_map: installed/reinstall/etc map done: %.3fs" (chrono ()); + let chrono = OpamConsole.timer () in let version_lag_map = OpamPackage.Name.Map.fold (fun name version_set acc -> let nvers, vs = @@ -220,6 +236,8 @@ let opam2cudf_map universe version_map packages = (OpamPackage.to_map packages) OpamPackage.Map.empty in + log ~level:3 "opam2cudf_map: version_map done: %.3fs" (chrono ()); + let chrono = OpamConsole.timer () in let extras_maps = List.map (fun (label, set) -> OpamPackage.Set.fold (fun nv -> @@ -227,6 +245,8 @@ let opam2cudf_map universe version_map packages = (packages %% set) OpamPackage.Map.empty) universe.u_attrs in + log ~level:3 "opam2cudf_map: extra_maps done: %.3fs" (chrono ()); + let chrono = OpamConsole.timer () in let add elts f map = OpamPackage.Map.merge (fun nv a b -> match a, b with @@ -255,6 +275,7 @@ let opam2cudf_map universe version_map packages = add m (fun _ x cp -> {cp with Cudf.pkg_extra = x :: cp.Cudf.pkg_extra})) extras_maps in + log ~level:3 "opam2cudf_map: univ0 done: %.3fs" (chrono ()); let preresolve_deps f = OpamFilter.atomise_extended f |> OpamFormula.map @@ -269,37 +290,47 @@ let opam2cudf_map universe version_map packages = Atom (name_to_cudf name, (filter, cstr))) |> OpamFormula.cnf_of_formula in - let depends_map = - OpamPackage.Map.map preresolve_deps - (only_packages universe.u_depends) - in - let depends_map = - let unav_dep = - OpamFormula.Atom (OpamCudf.unavailable_package_name, (FBool true, None)) - in - OpamPackage.Set.fold (fun nv -> - OpamPackage.Map.update nv - (fun deps -> OpamFormula.ands [unav_dep; deps]) - OpamFormula.Empty) - (universe.u_installed -- universe.u_available) - depends_map + let depends_map_prom = Task.async task_pool (fun () -> + let chrono = OpamConsole.timer () in + let depends_map = + OpamPackage.Map.map preresolve_deps + (only_packages universe.u_depends) + in + let depends_map = + let unav_dep = + OpamFormula.Atom (OpamCudf.unavailable_package_name, (FBool true, None)) + in + OpamPackage.Set.fold (fun nv -> + OpamPackage.Map.update nv + (fun deps -> OpamFormula.ands [unav_dep; deps]) + OpamFormula.Empty) + (universe.u_installed -- universe.u_available) + depends_map + in + log ~level:3 "opam2cudf_map: depends_map done: %.3fs" (chrono ()); + depends_map) in + let chrono = OpamConsole.timer () in let depopts_map = OpamPackage.Map.map preresolve_deps (only_packages universe.u_depopts) in - let conflicts_map = - OpamPackage.Map.mapi - (fun nv conflicts -> - (nv.name, None) :: - (* prevents install of multiple versions of the same pkg *) - OpamFormula.set_to_disjunction universe.u_packages conflicts) - (only_packages universe.u_conflicts) - in - let conflicts_map_resolved = - OpamPackage.Map.map (List.rev_map (atom2cudf universe version_map)) - conflicts_map - in + let conflicts_map_resolved_prom = Task.async task_pool (fun () -> + let chrono = OpamConsole.timer () in + let conflicts_map = OpamPackage.Map.mapi + (fun nv conflicts -> + (nv.name, None) :: + (* prevents install of multiple versions of the same pkg *) + OpamFormula.set_to_disjunction universe.u_packages conflicts) + (only_packages universe.u_conflicts) + in + let conflicts_map_resolved = OpamPackage.Map.map (List.rev_map (atom2cudf universe version_map)) conflicts_map in + log ~level:3 "opam2cudf_map: conflicts_map done: %.3fs" (chrono ()); + conflicts_map_resolved) + in + log ~level:3 "opam2cudf_map: other stuff done: %.3fs" (chrono ()); + let depends_map = Task.await task_pool depends_map_prom in + let conflicts_map_resolved = Task.await task_pool conflicts_map_resolved_prom in fun ~depopts ~build ~post -> let all_depends_map = if depopts then @@ -323,21 +354,21 @@ let opam2cudf_map universe version_map packages = |> add depends_map_resolved (fun _ depends cp -> {cp with Cudf.depends}) |> add conflicts_map_resolved (fun _ conflicts cp -> {cp with Cudf.conflicts}) -let opam2cudf_set universe version_map packages = - let load_f = opam2cudf_map universe version_map packages in +let opam2cudf_set ~task_pool universe version_map packages = + let load_f = opam2cudf_map ~task_pool universe version_map packages in fun ~depopts ~build ~post -> OpamPackage.Map.fold (fun _ -> OpamCudf.Set.add) (load_f ~depopts ~build ~post) OpamCudf.Set.empty -let load_cudf_packages opam_universe ?version_map opam_packages = +let load_cudf_packages ~task_pool opam_universe ?version_map opam_packages = let chrono = OpamConsole.timer () in let version_map = match version_map with | Some vm -> vm - | None -> cudf_versions_map opam_universe in + | None -> cudf_versions_map ~task_pool opam_universe in log ~level:3 "Load cudf universe: opam2cudf"; let univ_gen = - opam2cudf_map opam_universe version_map opam_packages + opam2cudf_map ~task_pool opam_universe version_map opam_packages in log ~level:3 "Preload of cudf universe: done in %.3fs" (chrono ()); fun ?(add_invariant=false) ?(depopts=false) ~build ~post () -> @@ -366,8 +397,8 @@ let map_to_cudf_universe cudf_packages_map = "Malformed CUDF universe (%s)" s (* load a cudf universe from an opam one *) -let load_cudf_universe opam_universe ?version_map opam_packages = - let load_f = load_cudf_packages opam_universe ?version_map opam_packages in +let load_cudf_universe ~task_pool opam_universe ?version_map opam_packages = + let load_f = load_cudf_packages ~task_pool opam_universe ?version_map opam_packages in fun ?add_invariant ?depopts ~build ~post () -> log "Load cudf universe (depopts:%a, build:%b, post:%b)" (slog string_of_bool) OpamStd.Option.Op.(depopts +! false) @@ -381,10 +412,10 @@ let load_cudf_universe opam_universe ?version_map opam_packages = let load_cudf_universe_with_packages opam_universe ?version_map all_packages - ?add_invariant ?depopts ~build ~post + ?add_invariant ?depopts ~task_pool ~build ~post opam_packages = let cudf_packages_map = - load_cudf_packages opam_universe ?version_map all_packages + load_cudf_packages ~task_pool opam_universe ?version_map all_packages ?add_invariant ?depopts ~build ~post () in map_to_cudf_universe cudf_packages_map, @@ -435,14 +466,19 @@ let map_request f r = let cycle_conflict ~version_map univ cycles = OpamCudf.cycle_conflict ~version_map univ cycles -let resolve universe request = +let resolve ~task_pool universe request = log "resolve request=%a" (slog string_of_request) request; - let all_packages = universe.u_available ++ universe.u_installed in - let version_map = cudf_versions_map universe in - let univ_gen = load_cudf_universe universe ~version_map all_packages in - let cudf_universe = univ_gen ~depopts:false ~build:true ~post:true () in - let requested_names = - OpamPackage.Name.Set.of_list (List.map fst request.wish_all) + let version_map_prom = Task.async task_pool (fun () -> cudf_versions_map ~task_pool universe) in + let univ_gen_prom = Task.async task_pool (fun () -> + let all_packages = universe.u_available ++ universe.u_installed in + load_cudf_universe ~task_pool universe ~version_map:(Task.await task_pool version_map_prom) all_packages) + in + let cudf_universe_prom = Task.async task_pool (fun () -> + let univ_gen = Task.await task_pool univ_gen_prom in + univ_gen ~depopts:false ~build:true ~post:true ()) + in + let requested_names_prom = + Task.async task_pool (fun () -> OpamPackage.Name.Set.of_list (List.map fst request.wish_all)) in let request = let extra_attributes = @@ -451,6 +487,7 @@ let resolve universe request = in { request with extra_attributes } in + let version_map = Task.await task_pool version_map_prom in let request, deprequest_pkg = let conj = OpamFormula.ands_to_list request.wish_install in let conj, deprequest = @@ -463,12 +500,15 @@ let resolve universe request = let invariant_pkg = opam_invariant_package version_map universe.u_invariant in + let univ_gen = Task.await task_pool univ_gen_prom in + let cudf_universe = Task.await task_pool cudf_universe_prom in + let chrono = OpamConsole.timer () in let solution = try Cudf.add_package cudf_universe invariant_pkg; Cudf.add_package cudf_universe deprequest_pkg; let resp = - OpamCudf.resolve ~extern:true ~version_map cudf_universe cudf_request + OpamCudf.resolve ~task_pool ~extern:true ~version_map cudf_universe cudf_request in Cudf.remove_package cudf_universe OpamCudf.opam_deprequest_package; Cudf.remove_package cudf_universe OpamCudf.opam_invariant_package; @@ -480,6 +520,7 @@ let resolve universe request = OpamStd.Sys.(Exit (get_exit_code `Solver_failure)) bt in + log "solution done %.3f" (chrono ()); match solution with | Conflicts _ as c -> c | Success actions -> @@ -489,7 +530,7 @@ let resolve universe request = let atomic_actions = OpamCudf.atomic_actions ~simple_universe ~complete_universe actions in - OpamCudf.trim_actions cudf_universe requested_names atomic_actions; + OpamCudf.trim_actions cudf_universe (Task.await task_pool requested_names_prom) atomic_actions; Success atomic_actions with OpamCudf.Cyclic_actions cycles -> cycle_conflict ~version_map complete_universe cycles @@ -510,12 +551,12 @@ let dosetrim f = ignore (f ~callback ~explain:false); !trimmed_pkgs -let coinstallable_subset universe ?(add_invariant=true) set packages = +let coinstallable_subset ~task_pool universe ?(add_invariant=true) set packages = log "subset of coinstallable with %a within %a" (slog OpamPackage.Set.to_string) set (slog OpamPackage.Set.to_string) packages; let cudf_packages_map = - load_cudf_packages ~add_invariant ~build:true ~post:true universe + load_cudf_packages ~add_invariant ~task_pool ~build:true ~post:true universe (universe.u_available ++ set ++ packages) () in let cudf_set, cudf_packages_map = @@ -555,24 +596,22 @@ let coinstallable_subset universe ?(add_invariant=true) set packages = OpamPackage.Set.empty cudf_coinstallable -let installable_subset universe packages = - coinstallable_subset - universe ~add_invariant:true OpamPackage.Set.empty packages +let installable_subset ~task_pool universe packages = + coinstallable_subset ~task_pool universe ~add_invariant:true OpamPackage.Set.empty packages -let installable universe = - installable_subset universe universe.u_available +let installable ~task_pool universe = + installable_subset ~task_pool universe universe.u_available module PkgGraph = Graph.Imperative.Digraph.ConcreteBidirectional(OpamPackage) -let dependency_graph - ~depopts ~build ~post ~installed ?(unavailable=false) +let dependency_graph ~task_pool ~depopts ~build ~post ~installed ?(unavailable=false) universe = let u_packages = if installed then universe.u_installed else if unavailable then universe.u_packages else universe.u_available in let cudf_graph = - load_cudf_universe ~depopts ~build ~post universe u_packages () |> + load_cudf_universe ~task_pool ~depopts ~build ~post universe u_packages () |> OpamCudf.Graph.of_universe in let g = PkgGraph.create ~size:(OpamCudf.Graph.nb_vertex cudf_graph) () in @@ -584,23 +623,25 @@ let dependency_graph cudf_graph; g -let dependency_sort ~depopts ~build ~post universe packages = +let dependency_sort ~task_pool ~depopts ~build ~post universe packages = let cudf_universe, cudf_packages = - load_cudf_universe_with_packages + load_cudf_universe_with_packages ~task_pool ~depopts ~build ~post universe universe.u_packages packages in List.map OpamCudf.cudf2opam (OpamCudf.dependency_sort cudf_universe cudf_packages) -let coinstallability_check universe packages = - let version_map = cudf_versions_map universe in +let coinstallability_check ~task_pool universe packages = + let version_map = cudf_versions_map ~task_pool universe in let cudf_universe, cudf_packages = load_cudf_universe_with_packages + ~task_pool ~build:true ~post:true ~add_invariant:true universe ~version_map universe.u_packages packages in + let res = match - Dose_algo.Depsolver.edos_coinstall cudf_universe + Dose_algo.Depsolver.edos_coinstall ~task_pool cudf_universe (OpamCudf.Set.elements cudf_packages) with | { Dose_algo.Diagnostic.result = Dose_algo.Diagnostic.Success _; _ } -> @@ -609,12 +650,14 @@ let coinstallability_check universe packages = match OpamCudf.make_conflicts ~version_map cudf_universe c with | Conflicts cs -> Some cs | _ -> None + in + res -let check_for_conflicts universe = - coinstallability_check universe universe.u_installed +let check_for_conflicts ~task_pool universe = + coinstallability_check ~task_pool universe universe.u_installed -let atom_coinstallability_check universe atoms = - let version_map = cudf_versions_map universe in +let atom_coinstallability_check ~task_pool universe atoms = + let version_map = cudf_versions_map ~task_pool universe in let check_pkg = { Cudf.default_package with package = "=check_coinstallability"; @@ -625,11 +668,14 @@ let atom_coinstallability_check universe atoms = (check_pkg :: opam_invariant_package version_map universe.u_invariant :: OpamCudf.Set.elements - (opam2cudf_set universe version_map universe.u_available + (opam2cudf_set ~task_pool universe version_map universe.u_available ~depopts:false ~build:true ~post:true)) in - Dose_algo.Depsolver.edos_install cudf_universe check_pkg - |> Dose_algo.Diagnostic.is_solution + let res = + Dose_algo.Depsolver.edos_install ~task_pool cudf_universe check_pkg + |> Dose_algo.Diagnostic.is_solution + in + res let new_packages sol = OpamCudf.ActionGraph.fold_vertex (fun action packages -> @@ -772,10 +818,10 @@ let print_solution ~messages ~append ~requested ~reinstall ~available print_actions (function `Change (`Up,_,_) -> true | _ -> false); print_actions (function `Install _ -> true | _ -> false) -let dump_universe universe oc = - let version_map = cudf_versions_map universe in +let dump_universe ~task_pool universe oc = + let version_map = cudf_versions_map ~task_pool universe in let cudf_univ = - load_cudf_universe ~depopts:false ~build:true ~post:true ~version_map + load_cudf_universe ~task_pool ~depopts:false ~build:true ~post:true ~version_map universe universe.u_available () in OpamCudf.dump_universe oc cudf_univ; (* Add explicit bindings to retrieve original versions of non-available and diff --git a/src/solver/opamSolver.mli b/src/solver/opamSolver.mli index c48ef25dd0a..a533a6339db 100644 --- a/src/solver/opamSolver.mli +++ b/src/solver/opamSolver.mli @@ -58,7 +58,7 @@ val solution_to_json : solution OpamJson.encoder val solution_of_json : solution OpamJson.decoder (** Computes an opam->cudf version map from an universe *) -val cudf_versions_map: universe -> int OpamPackage.Map.t +val cudf_versions_map: task_pool:Domainslib.Task.pool -> universe -> int OpamPackage.Map.t (** Creates a CUDF universe from an OPAM universe, including the given packages. Evaluation of the first 3 arguments is staged. Warning: when [depopts] is @@ -69,6 +69,7 @@ val cudf_versions_map: universe -> int OpamPackage.Map.t [Cudf.remove_package universe OpamCudf.opam_invariant_package] before exporting the results *) val load_cudf_universe: + task_pool:Domainslib.Task.pool -> universe -> ?version_map:int package_map -> package_set -> ?add_invariant:bool -> ?depopts:bool -> build:bool -> post:bool -> unit -> @@ -89,6 +90,7 @@ val request: (** Given a description of packages, return a solution preserving the consistency of the initial description. *) val resolve : + task_pool:Domainslib.Task.pool -> universe -> atom request -> (solution, OpamCudf.conflict) result @@ -96,14 +98,15 @@ val resolve : val get_atomic_action_graph : solution -> ActionGraph.t (** Keep only the packages that are installable. *) -val installable: universe -> package_set +val installable: task_pool:Domainslib.Task.pool -> universe -> package_set (** Like [installable], but within a subset and potentially much faster *) -val installable_subset: universe -> package_set -> package_set +val installable_subset: task_pool:Domainslib.Task.pool -> universe -> package_set -> package_set (** Sorts the given package set in topological order (as much as possible, beware of cycles in particular if [post] is [true]) *) val dependency_sort : + task_pool:Domainslib.Task.pool -> depopts:bool -> build:bool -> post:bool -> universe -> package_set -> @@ -112,6 +115,7 @@ val dependency_sort : module PkgGraph: Graph.Sig.I with type V.t = OpamPackage.t val dependency_graph : + task_pool:Domainslib.Task.pool -> depopts:bool -> build:bool -> post:bool -> installed:bool -> ?unavailable:bool -> @@ -119,26 +123,27 @@ val dependency_graph : (** Check the current set of installed packages in a universe for inconsistencies *) -val check_for_conflicts : universe -> OpamCudf.conflict option +val check_for_conflicts : task_pool:Domainslib.Task.pool -> universe -> OpamCudf.conflict option (** Checks the given package set for complete installability ; returns None if they can all be installed together *) -val coinstallability_check : universe -> package_set -> OpamCudf.conflict option +val coinstallability_check : task_pool:Domainslib.Task.pool -> universe -> package_set -> OpamCudf.conflict option (** Checks if the given atoms can be honored at the same time in the given universe *) -val atom_coinstallability_check : universe -> atom list -> bool +val atom_coinstallability_check : + task_pool:Domainslib.Task.pool -> universe -> atom list -> bool (** [coinstallable_subset univ set packages] returns the subset of [packages] which are individually co-installable with [set], i.e. that can be installed while [set] remains installed. This returns the empty set if [set] is already not coinstallable. `add_invariant` defaults to [true] *) -val coinstallable_subset : +val coinstallable_subset : task_pool:Domainslib.Task.pool -> universe -> ?add_invariant:bool -> package_set -> package_set -> package_set (** Dumps a cudf file containing all available packages in the given universe, plus version bindings (as '#v2v' comments) for the other ones. *) -val dump_universe: universe -> out_channel -> unit +val dump_universe: task_pool:Domainslib.Task.pool -> universe -> out_channel -> unit (** Filters actions in a solution. Dependents of a removed actions are removed to keep consistency unless [recursive] is set to false *) diff --git a/src/solver/opamSolverConfig.ml b/src/solver/opamSolverConfig.ml index 1df6755e121..79a7a257141 100644 --- a/src/solver/opamSolverConfig.ml +++ b/src/solver/opamSolverConfig.ml @@ -50,14 +50,14 @@ end type t = { cudf_file: string option; - solver: (module OpamCudfSolver.S) Lazy.t; + solver: (module OpamCudfSolver.S) OpamLazy.t; best_effort: bool; (* The following are options because the default can only be known once the solver is known, so we set it only if no customisation was made *) - solver_preferences_default: string option Lazy.t; - solver_preferences_upgrade: string option Lazy.t; - solver_preferences_fixup: string option Lazy.t; - solver_preferences_best_effort_prefix: string option Lazy.t; + solver_preferences_default: string option OpamLazy.t; + solver_preferences_upgrade: string option OpamLazy.t; + solver_preferences_fixup: string option OpamLazy.t; + solver_preferences_best_effort_prefix: string option OpamLazy.t; solver_timeout: float option; solver_allow_suboptimal: bool; cudf_trim: string option; @@ -68,12 +68,12 @@ type t = { type 'a options_fun = ?cudf_file:string option -> - ?solver:((module OpamCudfSolver.S) Lazy.t) -> + ?solver:((module OpamCudfSolver.S) OpamLazy.t) -> ?best_effort:bool -> - ?solver_preferences_default:string option Lazy.t -> - ?solver_preferences_upgrade:string option Lazy.t -> - ?solver_preferences_fixup:string option Lazy.t -> - ?solver_preferences_best_effort_prefix:string option Lazy.t -> + ?solver_preferences_default:string option OpamLazy.t -> + ?solver_preferences_upgrade:string option OpamLazy.t -> + ?solver_preferences_fixup:string option OpamLazy.t -> + ?solver_preferences_best_effort_prefix:string option OpamLazy.t -> ?solver_timeout:float option -> ?solver_allow_suboptimal:bool -> ?cudf_trim:string option -> @@ -83,17 +83,17 @@ type 'a options_fun = 'a let default = - let solver = lazy ( + let solver = OpamLazy.create (fun () -> OpamCudfSolver.get_solver OpamCudfSolver.default_solver_selection ) in { cudf_file = None; solver; best_effort = false; - solver_preferences_default = lazy None; - solver_preferences_upgrade = lazy None; - solver_preferences_fixup = lazy None; - solver_preferences_best_effort_prefix = lazy None; + solver_preferences_default = OpamLazy.from_val None; + solver_preferences_upgrade = OpamLazy.from_val None; + solver_preferences_fixup = OpamLazy.from_val None; + solver_preferences_best_effort_prefix = OpamLazy.from_val None; solver_timeout = Some 60.; solver_allow_suboptimal = true; cudf_trim = None; @@ -148,28 +148,31 @@ let r = ref default let update ?noop:_ = setk (fun cfg () -> r := cfg) !r let with_auto_criteria config = - let criteria = lazy ( - let module S = (val Lazy.force config.solver) in + let criteria = OpamLazy.create (fun () -> + let module S = (val OpamLazy.force config.solver) in S.default_criteria ) in set config ~solver_preferences_default: - (lazy (match config.solver_preferences_default with - | lazy None -> Some (Lazy.force criteria).OpamCudfSolver.crit_default - | lazy some -> some)) + (OpamLazy.create (fun () -> + match OpamLazy.force config.solver_preferences_default with + | None -> Some (OpamLazy.force criteria).OpamCudfSolver.crit_default + | some -> some)) ~solver_preferences_upgrade: - (lazy (match config.solver_preferences_upgrade with - | lazy None -> Some (Lazy.force criteria).OpamCudfSolver.crit_upgrade - | lazy some -> some)) + (OpamLazy.create (fun () -> + match OpamLazy.force config.solver_preferences_upgrade with + | None -> Some (OpamLazy.force criteria).OpamCudfSolver.crit_upgrade + | some -> some)) ~solver_preferences_fixup: - (lazy (match config.solver_preferences_fixup with - | lazy None -> Some (Lazy.force criteria).OpamCudfSolver.crit_fixup - | lazy some -> some)) + (OpamLazy.create (fun () -> + match OpamLazy.force config.solver_preferences_fixup with + | None -> Some (OpamLazy.force criteria).OpamCudfSolver.crit_fixup + | some -> some)) ~solver_preferences_best_effort_prefix: - (lazy (match config.solver_preferences_best_effort_prefix with - | lazy None -> - (Lazy.force criteria).OpamCudfSolver.crit_best_effort_prefix - | lazy some -> some)) + (OpamLazy.create (fun () -> + match OpamLazy.force config.solver_preferences_best_effort_prefix with + | None -> (OpamLazy.force criteria).OpamCudfSolver.crit_best_effort_prefix + | some -> some)) () let initk k = @@ -177,20 +180,20 @@ let initk k = let solver = let open OpamCudfSolver in match E.externalsolver () with - | Some "" -> lazy (get_solver ~internal:true default_solver_selection) - | Some s -> lazy (solver_of_string s) + | Some "" -> OpamLazy.create (fun () ->get_solver ~internal:true default_solver_selection) + | Some s -> OpamLazy.create (fun () ->solver_of_string s) | None -> let internal = E.useinternalsolver () ++ E.noaspcud () in - lazy (get_solver ?internal default_solver_selection) + OpamLazy.create (fun () ->get_solver ?internal default_solver_selection) in let criteria = - E.criteria () >>| fun c -> lazy (Some c) in + E.criteria () >>| fun c -> OpamLazy.create (fun () ->Some c) in let upgrade_criteria = - (E.upgradecriteria () >>| fun c -> lazy (Some c)) ++ criteria in + (E.upgradecriteria () >>| fun c -> OpamLazy.create (fun () ->Some c)) ++ criteria in let fixup_criteria = - E.fixupcriteria () >>| fun c -> (lazy (Some c)) in + E.fixupcriteria () >>| fun c -> (OpamLazy.create (fun () ->Some c)) in let best_effort_prefix_criteria = - E.besteffortprefixcriteria () >>| fun c -> (lazy (Some c)) in + E.besteffortprefixcriteria () >>| fun c -> (OpamLazy.create (fun () ->Some c)) in let solver_timeout = E.solvertimeout () >>| fun f -> if f <= 0. then None else Some f in setk (setk (fun c -> r := with_auto_criteria c; k)) !r @@ -214,11 +217,11 @@ let best_effort = let already_warned = ref false in fun () -> !r.best_effort && - let crit = match Lazy.force !r.solver_preferences_default with + let crit = match OpamLazy.force !r.solver_preferences_default with | Some c -> c | None -> failwith "Solver criteria uninitialised" in - let pfx = Lazy.force !r.solver_preferences_best_effort_prefix in + let pfx = OpamLazy.force !r.solver_preferences_best_effort_prefix in pfx <> None || OpamStd.String.contains ~sub:"opam-query" crit || (if not !already_warned then begin @@ -238,18 +241,18 @@ let criteria kind = | `Fixup -> !r.solver_preferences_fixup in let str = - match Lazy.force crit with + match OpamLazy.force crit with | Some c -> c | None -> failwith "Solver criteria uninitialised" in if !r.best_effort then - match !r.solver_preferences_best_effort_prefix with - | lazy (Some pfx) -> pfx ^ str - | lazy None -> str + match OpamLazy.force !r.solver_preferences_best_effort_prefix with + | Some pfx -> pfx ^ str + | None -> str else str let call_solver ~criteria cudf = - let module S = (val Lazy.force (!r.solver)) in + let module S = (val OpamLazy.force (!r.solver)) in OpamConsole.log "SOLVER" "Calling solver %s with criteria %s" (OpamCudfSolver.get_name (module S)) criteria; let chrono = OpamConsole.timer () in diff --git a/src/solver/opamSolverConfig.mli b/src/solver/opamSolverConfig.mli index 46e1da21fd8..ec06933547a 100644 --- a/src/solver/opamSolverConfig.mli +++ b/src/solver/opamSolverConfig.mli @@ -33,12 +33,12 @@ end type t = private { cudf_file: string option; - solver: (module OpamCudfSolver.S) Lazy.t; + solver: (module OpamCudfSolver.S) OpamLazy.t; best_effort: bool; - solver_preferences_default: string option Lazy.t; - solver_preferences_upgrade: string option Lazy.t; - solver_preferences_fixup: string option Lazy.t; - solver_preferences_best_effort_prefix: string option Lazy.t; + solver_preferences_default: string option OpamLazy.t; + solver_preferences_upgrade: string option OpamLazy.t; + solver_preferences_fixup: string option OpamLazy.t; + solver_preferences_best_effort_prefix: string option OpamLazy.t; solver_timeout: float option; solver_allow_suboptimal: bool; cudf_trim: string option; @@ -49,12 +49,12 @@ type t = private { type 'a options_fun = ?cudf_file:string option -> - ?solver:(module OpamCudfSolver.S) Lazy.t -> + ?solver:(module OpamCudfSolver.S) OpamLazy.t -> ?best_effort:bool -> - ?solver_preferences_default:string option Lazy.t -> - ?solver_preferences_upgrade:string option Lazy.t -> - ?solver_preferences_fixup:string option Lazy.t -> - ?solver_preferences_best_effort_prefix:string option Lazy.t -> + ?solver_preferences_default:string option OpamLazy.t -> + ?solver_preferences_upgrade:string option OpamLazy.t -> + ?solver_preferences_fixup:string option OpamLazy.t -> + ?solver_preferences_best_effort_prefix:string option OpamLazy.t -> ?solver_timeout:float option -> ?solver_allow_suboptimal:bool -> ?cudf_trim:string option -> diff --git a/src/state/dune b/src/state/dune index 15f501bf3f6..604082b2711 100644 --- a/src/state/dune +++ b/src/state/dune @@ -1,7 +1,7 @@ (library (name opam_state) (public_name opam-state) - (libraries opam-repository re spdx_licenses) + (libraries opam-repository re spdx_licenses domainslib) (synopsis "OCaml Package Manager instance management library") (modules_without_implementation OpamStateTypes) (modules :standard) diff --git a/src/state/opamEnv.ml b/src/state/opamEnv.ml index 42f4a30889e..a31c4412f85 100644 --- a/src/state/opamEnv.ml +++ b/src/state/opamEnv.ml @@ -63,7 +63,7 @@ let transform_format ~(sepfmt:sep_path_format) = | `rewrite _ -> OpamSystem.forward_to_back) | Host | Host_quoted -> (* noop on non windows *) - (Lazy.force OpamSystem.get_cygpath_path_transform) ~pathlist:false + (OpamLazy.force OpamSystem.get_cygpath_path_transform) ~pathlist:false in match format with | Target | Host -> translate @@ -81,7 +81,7 @@ let resolve_separator_and_format : OpamStd.Option.(Op.( of_Not_found (OpamStd.List.assoc OpamVariable.equal fv) - OpamSysPoll.variables >>= Lazy.force)) + OpamSysPoll.variables >>= OpamLazy.force)) in let resolve var to_str formula = let evaluated = @@ -299,15 +299,15 @@ let map_update_names env_keys updates = in List.map convert updates -let global_env_keys = lazy ( +let global_env_keys = OpamLazy.create (fun () -> OpamStd.Env.list () |> List.map fst |> OpamStd.Env.Name.Set.of_list) -let updates_from_previous_instance = lazy ( +let updates_from_previous_instance = OpamLazy.create (fun () -> let get_env env_file = OpamStd.Option.map - (map_update_names (Lazy.force global_env_keys)) + (map_update_names (OpamLazy.force global_env_keys)) (OpamFile.Environment.read_opt env_file) in let open OpamStd.Option.Op in @@ -331,7 +331,7 @@ let expand (updates: spf_resolved env_update list) : env = let updates = if Sys.win32 then (* Preserve the case of updates which are already in env *) - map_update_names (Lazy.force global_env_keys) updates + map_update_names (OpamLazy.force global_env_keys) updates else updates in @@ -346,7 +346,7 @@ let expand (updates: spf_resolved env_update list) : env = in (* Reverse all previous updates, in reverse order, on current environment *) let reverts = - match Lazy.force updates_from_previous_instance with + match OpamLazy.force updates_from_previous_instance with | None -> [] | Some updates -> List.fold_right (fun upd defs0 -> @@ -876,7 +876,7 @@ let env_hook_script shell = let source root shell f = let fname = OpamFilename.to_string (OpamPath.init root // f) in let unix_transform ?using_backslashes () = - let cygpath = Lazy.force OpamSystem.get_cygpath_path_transform in + let cygpath = OpamLazy.force OpamSystem.get_cygpath_path_transform in cygpath ~pathlist:false fname |> OpamStd.Env.escape_single_quotes ?using_backslashes in diff --git a/src/state/opamFormatUpgrade.ml b/src/state/opamFormatUpgrade.ml index 7f9578f9b56..2489761a2bd 100644 --- a/src/state/opamFormatUpgrade.ml +++ b/src/state/opamFormatUpgrade.ml @@ -378,12 +378,12 @@ let from_1_1_to_1_2 ~on_the_fly:_ root config = OpamFilename.move_dir ~src:d ~dst:(OpamFilename.Dir.of_string (Filename.chop_suffix s ".pinned")) in - let packages = lazy ( + let packages = OpamLazy.create (fun () -> OpamPackage.Set.of_list (OpamPackage.Map.keys (OpamFile.Package_index.safe_read - (OpamFile.make (root / "repo" // "package-index")))) - ) in + (OpamFile.make (root / "repo" // "package-index"))))) + in OpamSwitch.Map.iter (fun switch _ -> let switch_root = root / OpamSwitch.to_string switch in let pinned_version name = @@ -398,7 +398,7 @@ let from_1_1_to_1_2 ~on_the_fly:_ root config = with e -> OpamStd.Exn.fatal e; try OpamPackage.version - (OpamPackage.max_version (Lazy.force packages) name) + (OpamPackage.max_version (OpamLazy.force packages) name) with Not_found -> OpamPackage.Version.of_string "0" in let fix_version nv = let obsolete_pinned_v = OpamPackage.Version.of_string "pinned" in @@ -1136,24 +1136,20 @@ let erase_plugin_links root = if OpamFilename.exists_dir plugins_bin then List.iter OpamFilename.remove @@ OpamFilename.files_and_links plugins_bin -let flock_root = - let dontblock = - let t = lazy ( - (* Deadlock until one is killed in interactive mode, but abort in batch *) - if OpamStd.Sys.tty_out then None else Some true - ) in - fun () -> Lazy.force t - in - fun ?global_lock kind root -> - try - let global_lock = match global_lock with - | Some g -> g - | None -> OpamFilename.flock `Lock_read (OpamPath.lock root) - in - OpamFilename.with_flock_upgrade kind ?dontblock:(dontblock ()) global_lock - with OpamSystem.Locked -> - OpamConsole.error_and_exit `Locked - "Could not acquire lock for performing format upgrade." +let flock_root_dontblock = OpamLazy.memo_unit (fun () -> + (* Deadlock until one is killed in interactive mode, but abort in batch *) + if OpamStd.Sys.tty_out then None else Some true) + +let flock_root ?global_lock kind root = + try + let global_lock = match global_lock with + | Some g -> g + | None -> OpamFilename.flock `Lock_read (OpamPath.lock root) + in + OpamFilename.with_flock_upgrade kind ?dontblock:(flock_root_dontblock ()) global_lock + with OpamSystem.Locked -> + OpamConsole.error_and_exit `Locked + "Could not acquire lock for performing format upgrade." let as_necessary ?reinit requested_lock global_lock root config = let root_version = @@ -1331,8 +1327,8 @@ let as_necessary_repo_switch_light_upgrade lock_kind kind gt = (OpamVersion.to_string (OpamFile.Config.opam_root_version gt.config)); if OpamConsole.confirm "Continue?" then flock_root `Lock_write gt.root @@ fun _ -> - OpamFile.Config.write config_f gt.config; - erase_plugin_links gt.root + OpamFile.Config.write config_f gt.config; + erase_plugin_links gt.root else OpamStd.Sys.exit_because `Aborted | _, _ -> () diff --git a/src/state/opamGlobalState.ml b/src/state/opamGlobalState.ml index 811d20da2e1..283d4a0c4ec 100644 --- a/src/state/opamGlobalState.ml +++ b/src/state/opamGlobalState.ml @@ -85,7 +85,7 @@ let load lock_kind = let global_variables = List.fold_left (fun acc (v,value) -> OpamVariable.Map.add v - (lazy (Some (OpamStd.Option.default (S "unknown") (Lazy.force value))), + (OpamLazy.create (fun () -> Some (OpamStd.Option.default (S "unknown") (OpamLazy.force value))), (* Careful on changing it, it is used to determine user defined variables on `config report`. See [OpamConfigCommand.help]. *) inferred_from_system) @@ -95,21 +95,21 @@ let load lock_kind = in let global_variables = List.fold_left (fun acc (v,value,doc) -> - OpamVariable.Map.add v (lazy (Some value), doc) acc) + OpamVariable.Map.add v (OpamLazy.create (fun () -> Some value), doc) acc) global_variables (OpamFile.Config.global_variables config) in let eval_variables = OpamFile.Config.eval_variables config in let global_variables = - let env = lazy (OpamEnv.get_pure () |> OpamTypesBase.env_array) in + let env = OpamLazy.create (fun () -> OpamEnv.get_pure () |> OpamTypesBase.env_array) in List.fold_left (fun acc (v, cmd, doc) -> OpamVariable.Map.update v (fun previous_value -> - (lazy - (try + (OpamLazy.create + (fun () -> try let ret = OpamSystem.read_command_output - ~env:(Lazy.force env) + ~env:(OpamLazy.force env) ~allow_stdin:false cmd in @@ -119,9 +119,9 @@ let load lock_kind = log "Failed to evaluate global variable %a: %a" (slog OpamVariable.to_string) v (slog Printexc.to_string) e; - Lazy.force (fst previous_value))), + OpamLazy.force (fst previous_value))), doc) - (lazy None, "") + (OpamLazy.create (fun () -> None), "") acc) global_variables eval_variables in diff --git a/src/state/opamMulticore.ml b/src/state/opamMulticore.ml new file mode 100644 index 00000000000..812bf42a208 --- /dev/null +++ b/src/state/opamMulticore.ml @@ -0,0 +1,26 @@ +open Domainslib + +(* Based on some empirical testing, this default is an apparent sweet spot. + The parallel algorithms used so far don't appear to benefit more from + more cores. *) +let max_default_num_cores = 5 + +let requested_num_cores = ref None + +let create_task_pool () = + let num_cores_to_use = + match !requested_num_cores with + | Some i -> i + | None -> + let num_cores = OpamSysPoll.cores () in + min max_default_num_cores num_cores + in + let num_domains = pred num_cores_to_use in + let task_pool = Task.setup_pool ~num_domains () in + task_pool + +let run_with_task_pool f = + let task_pool = create_task_pool () in + let res = Task.run task_pool (fun () -> f task_pool) in + Task.teardown_pool task_pool; + res diff --git a/src/state/opamMulticore.mli b/src/state/opamMulticore.mli new file mode 100644 index 00000000000..d20f9de4ba0 --- /dev/null +++ b/src/state/opamMulticore.mli @@ -0,0 +1,11 @@ + +(* Based on some empirical testing, this default is an apparent sweet spot. + The parallel algorithms used so far don't appear to benefit from + more cores than this. *) +val max_default_num_cores : int + +(* Hook for command-line args to override domains used. *) +val requested_num_cores : int option ref + +(* Creates a task pool and runs the given thunk with the task pool provided. *) +val run_with_task_pool : (Domainslib.Task.pool -> 'a) -> 'a diff --git a/src/state/opamPackageVar.ml b/src/state/opamPackageVar.ml index d113962bf4e..6683cff9a64 100644 --- a/src/state/opamPackageVar.ml +++ b/src/state/opamPackageVar.ml @@ -61,18 +61,23 @@ let resolve_global gt full_var = match V.Full.read_from_env full_var with | Some _ as c -> c | None -> - match OpamVariable.Map.find_opt var gt.global_variables with - | Some (lazy (Some _ as some), _) -> some - | _ -> + let default () = match V.to_string var with | "opam-version" -> Some (V.string OpamVersion.(to_string current)) - | "jobs" -> Some (V.int (OpamStateConfig.(Lazy.force !r.jobs))) + | "jobs" -> Some (V.int (OpamStateConfig.(OpamLazy.force !r.jobs))) | "root" -> Some (V.string (OpamFilename.Dir.to_string gt.root)) - | "make" -> Some (V.string OpamStateConfig.(Lazy.force !r.makecmd)) + | "make" -> Some (V.string OpamStateConfig.(OpamLazy.force !r.makecmd)) | "exe" -> Some (V.string (OpamStd.Sys.executable_name "")) | "switch" -> OpamStd.Option.map (OpamSwitch.to_string @> V.string) - (OpamStateConfig.get_switch_opt ()) + (OpamStateConfig.get_switch_opt ()) | _ -> None + in + match OpamVariable.Map.find_opt var gt.global_variables with + | None -> default () + | Some (lazyval, _) -> + match OpamLazy.force lazyval with + | None -> default () + | Some x -> Some x (** Resolve switch-global variables only, as allowed by the 'available:' field *) @@ -312,7 +317,7 @@ let resolve st ?opam:opam_arg ?(local=OpamVariable.Map.empty) v = or from temporary repository in /tmp *) let repos_roots reponame = match Hashtbl.find st.switch_repos.repos_tmp reponame with - | lazy repo_root -> repo_root + | repo_root -> OpamLazy.force repo_root | exception Not_found -> OpamRepositoryPath.root st.switch_global.root reponame in diff --git a/src/state/opamRepositoryState.ml b/src/state/opamRepositoryState.ml index f3f84343bb5..deb72bc02dc 100644 --- a/src/state/opamRepositoryState.ml +++ b/src/state/opamRepositoryState.ml @@ -121,8 +121,8 @@ let load_repo repo repo_root = (* Cleaning directories follows the repo path pattern: TMPDIR/opam-tmp-dir/repo-dir, defined in [load]. *) let clean_repo_tmp tmp_dir = - if Lazy.is_val tmp_dir then - (let dir = Lazy.force tmp_dir in + if OpamLazy.is_val tmp_dir then + (let dir = OpamLazy.force tmp_dir in OpamFilename.rmdir dir; let parent = OpamFilename.dirname_dir dir in if OpamFilename.dir_is_empty parent then @@ -140,7 +140,7 @@ let cleanup rt = let get_root_raw root repos_tmp name = match Hashtbl.find repos_tmp name with - | lazy repo_root -> repo_root + | repo_root -> OpamLazy.force repo_root | exception Not_found -> OpamRepositoryPath.root root name let get_root rt name = @@ -170,7 +170,7 @@ let load lock_kind gt = OpamRepositoryName.Map.filter (fun _ url -> url = None) repos_map in let repositories = OpamRepositoryName.Map.mapi mk_repo repos_map in - let repos_tmp_root = lazy (OpamFilename.mk_tmp_dir ()) in + let repos_tmp_root = OpamLazy.create (fun () -> OpamFilename.mk_tmp_dir ()) in let repos_tmp = Hashtbl.create 23 in OpamRepositoryName.Map.iter (fun name repo -> let uncompressed_root = OpamRepositoryPath.root gt.root repo.repo_name in @@ -178,8 +178,8 @@ let load lock_kind gt = if not (OpamFilename.exists_dir uncompressed_root) && OpamFilename.exists tar then - let tmp = lazy ( - let tmp_root = Lazy.force repos_tmp_root in + let tmp = OpamLazy.create (fun () -> + let tmp_root = OpamLazy.force repos_tmp_root in try (* We rely on this path pattern to clean the repo. cf. [clean_repo_tmp] *) @@ -307,4 +307,3 @@ let check_last_update () = OpamConsole.note "It seems you have not updated your repositories \ for a while. Consider updating them with:\n%s\n" (OpamConsole.colorise `bold "opam update"); - diff --git a/src/state/opamStateConfig.ml b/src/state/opamStateConfig.ml index 6d1eea5ac7a..512b96a515b 100644 --- a/src/state/opamStateConfig.ml +++ b/src/state/opamStateConfig.ml @@ -55,13 +55,13 @@ type t = { root_dir: OpamFilename.Dir.t; current_switch: OpamSwitch.t option; switch_from: provenance; - jobs: int Lazy.t; + jobs: int OpamLazy.t; dl_jobs: int; build_test: bool; build_doc: bool; dev_setup: bool; dryrun: bool; - makecmd: string Lazy.t; + makecmd: string OpamLazy.t; ignore_constraints_on: name_set; unlock_base: bool; no_env_notice: bool; @@ -89,17 +89,17 @@ let default = { ); current_switch = None; switch_from = `Default; - jobs = lazy (max 1 (OpamSysPoll.cores () - 1)); + jobs = OpamLazy.create (fun () -> max 1 (OpamSysPoll.cores () - 1)); dl_jobs = 3; build_test = false; build_doc = false; dev_setup = false; dryrun = false; - makecmd = lazy OpamStd.Sys.( + makecmd = OpamLazy.create (fun () -> OpamStd.Sys.( match os () with | FreeBSD | OpenBSD | NetBSD | DragonFly -> "gmake" | _ -> "make" - ); + )); ignore_constraints_on = OpamPackage.Name.Set.empty; unlock_base = false; no_env_notice = false; @@ -111,13 +111,13 @@ type 'a options_fun = ?root_dir:OpamFilename.Dir.t -> ?current_switch:OpamSwitch.t -> ?switch_from:provenance -> - ?jobs:(int Lazy.t) -> + ?jobs:(int OpamLazy.t) -> ?dl_jobs:int -> ?build_test:bool -> ?build_doc:bool -> ?dev_setup:bool -> ?dryrun:bool -> - ?makecmd:string Lazy.t -> + ?makecmd:string OpamLazy.t -> ?ignore_constraints_on:name_set -> ?unlock_base:bool -> ?no_env_notice:bool -> @@ -179,13 +179,13 @@ let initk k = ?root_dir:(E.root () >>| OpamFilename.Dir.of_string) ?current_switch ?switch_from - ?jobs:(E.jobs () >>| fun s -> lazy s) + ?jobs:(E.jobs () >>| fun s -> OpamLazy.create (fun () -> s)) ?dl_jobs:(E.downloadjobs ()) ?build_test:(E.withtest () ++ E.buildtest ()) ?build_doc:(E.withdoc () ++ E.builddoc ()) ?dev_setup:(E.withdevsetup()) ?dryrun:(E.dryrun ()) - ?makecmd:(E.makecmd () >>| fun s -> lazy s) + ?makecmd:(E.makecmd () >>| fun s -> OpamLazy.create (fun () -> s)) ?ignore_constraints_on: (E.ignoreconstraints () >>| fun s -> OpamStd.String.split s ',' |> @@ -380,14 +380,14 @@ let load_defaults ?lock_kind root_dir = OpamRepositoryConfig.update ?download_tool:(OpamFile.Config.dl_tool conf >>| function | (CString c,None)::_ as t - when OpamStd.String.ends_with ~suffix:"curl" c -> lazy (t, `Curl) - | t -> lazy (t, `Default)) + when OpamStd.String.ends_with ~suffix:"curl" c -> OpamLazy.create (fun () ->t, `Curl) + | t -> OpamLazy.create (fun () ->t, `Default)) ~validation_hook:(OpamFile.Config.validation_hook conf) (); update ?current_switch:(OpamFile.Config.switch conf) ~switch_from:`Default - ?jobs:(OpamFile.Config.jobs conf >>| fun s -> lazy s) + ?jobs:(OpamFile.Config.jobs conf >>| fun s -> OpamLazy.create (fun () -> s)) ~dl_jobs:(OpamFile.Config.dl_jobs conf) (); update ?current_switch (); diff --git a/src/state/opamStateConfig.mli b/src/state/opamStateConfig.mli index 85498a23eff..9f22006fd04 100644 --- a/src/state/opamStateConfig.mli +++ b/src/state/opamStateConfig.mli @@ -40,13 +40,13 @@ type t = private { root_dir: OpamFilename.Dir.t; current_switch: OpamSwitch.t option; switch_from: provenance; - jobs: int Lazy.t; + jobs: int OpamLazy.t; dl_jobs: int; build_test: bool; build_doc: bool; dev_setup: bool; dryrun: bool; - makecmd: string Lazy.t; + makecmd: string OpamLazy.t; ignore_constraints_on: name_set; unlock_base: bool; no_env_notice: bool; @@ -58,13 +58,13 @@ type 'a options_fun = ?root_dir:OpamFilename.Dir.t -> ?current_switch:OpamSwitch.t -> ?switch_from:provenance -> - ?jobs:(int Lazy.t) -> + ?jobs:(int OpamLazy.t) -> ?dl_jobs:int -> ?build_test:bool -> ?build_doc:bool -> ?dev_setup:bool -> ?dryrun:bool -> - ?makecmd:string Lazy.t -> + ?makecmd:string OpamLazy.t -> ?ignore_constraints_on:name_set -> ?unlock_base:bool -> ?no_env_notice:bool -> diff --git a/src/state/opamStateTypes.mli b/src/state/opamStateTypes.mli index 3a00a5089d8..3f53e2bf697 100644 --- a/src/state/opamStateTypes.mli +++ b/src/state/opamStateTypes.mli @@ -44,7 +44,7 @@ type +'a lock = [< unlocked > `Lock_write ] as 'a (** Type of global state global variables *) type gt_variables = - (variable_contents option Lazy.t * string) OpamVariable.Map.t + (variable_contents option OpamLazy.t * string) OpamVariable.Map.t type gt_changes = { gtc_repo: bool; gtc_switch: bool } @@ -90,7 +90,7 @@ type +'lock repos_state = { repo_opams: OpamFile.OPAM.t package_map repository_name_map; (** All opam files that can be found in the configured repositories *) - repos_tmp: (OpamRepositoryName.t, OpamFilename.Dir.t Lazy.t) Hashtbl.t; + repos_tmp: (OpamRepositoryName.t, OpamFilename.Dir.t OpamLazy.t) Hashtbl.t; (** Temporary directories containing the uncompressed contents of the repositories *) } constraint 'lock = 'lock lock @@ -135,11 +135,11 @@ type +'lock switch_state = { packages: package_set; (** The set of all known packages *) - sys_packages: sys_pkg_status package_map Lazy.t; + sys_packages: sys_pkg_status package_map OpamLazy.t; (** Map of package and their system dependencies packages status. Only initialised for otherwise available packages *) - available_packages: package_set Lazy.t; + available_packages: package_set OpamLazy.t; (** The set of available packages, filtered by their [available:] field *) pinned: package_set; @@ -158,10 +158,10 @@ type +'lock switch_state = { happen not to be installed at some point, but this indicates that the user would like them installed. *) - reinstall: package_set Lazy.t; + reinstall: package_set OpamLazy.t; (** The set of packages which need to be reinstalled *) - invalidated: package_set Lazy.t; + invalidated: package_set OpamLazy.t; (** The set of packages which are installed but no longer valid, e.g. because of removed system dependencies. Only packages which are unavailable end up in this set, they are otherwise put in [reinstall]. *) diff --git a/src/state/opamSwitchAction.ml b/src/state/opamSwitchAction.ml index be5d5018beb..5095347bdac 100644 --- a/src/state/opamSwitchAction.ml +++ b/src/state/opamSwitchAction.ml @@ -122,7 +122,7 @@ let add_to_reinstall st ~unpinned_only packages = OpamFilename.remove (OpamFile.filename reinstall_file) else OpamFile.PkgList.write reinstall_file reinstall; - { st with reinstall = lazy (Lazy.force st.reinstall ++ add_reinst_packages) } + { st with reinstall = OpamLazy.create (fun () -> OpamLazy.force st.reinstall ++ add_reinst_packages) } let set_current_switch gt st = if OpamSwitch.is_external st.switch then @@ -168,23 +168,23 @@ let remove_metadata st packages = st.switch_global.root st.switch nv)) packages -let update_switch_state ?installed ?installed_roots ?reinstall ?pinned st = +let update_switch_state ?installed ?installed_roots ?reinstall ?pinned ~task_pool st = let open OpamStd.Option.Op in let open OpamPackage.Set.Op in let installed = installed +! st.installed in - let reinstall0 = Lazy.force st.reinstall in + let reinstall0 = OpamLazy.force st.reinstall in let reinstall = (reinstall +! reinstall0) %% installed in let old_selections = OpamSwitchState.selections st in let st = { st with installed; installed_roots = installed_roots +! st.installed_roots; - reinstall = lazy reinstall; + reinstall = OpamLazy.create (fun () -> reinstall); pinned = pinned +! st.pinned; } in let compiler_packages = - OpamSwitchState.compute_invariant_packages st + OpamSwitchState.compute_invariant_packages ~task_pool st in let st = { st with compiler_packages } in if not OpamStateConfig.(!r.dryrun) then ( @@ -196,11 +196,11 @@ let update_switch_state ?installed ?installed_roots ?reinstall ?pinned st = ); st -let add_to_installed st ?(root=false) nv = +let add_to_installed ~task_pool st ?(root=false) nv = let st = - update_switch_state st + update_switch_state ~task_pool st ~installed:(OpamPackage.Set.add nv st.installed) - ~reinstall:(OpamPackage.Set.remove nv (Lazy.force st.reinstall)) + ~reinstall:(OpamPackage.Set.remove nv (OpamLazy.force st.reinstall)) ~installed_roots: (let roots = OpamPackage.Set.filter (fun nv1 -> nv1.name <> nv.name) @@ -223,14 +223,14 @@ let add_to_installed st ?(root=false) nv = ); st -let remove_from_installed ?(keep_as_root=false) st nv = +let remove_from_installed ?(keep_as_root=false) ~task_pool st nv = let rm = OpamPackage.Set.remove nv in let st = - update_switch_state st + update_switch_state ~task_pool st ~installed:(rm st.installed) ?installed_roots:(if keep_as_root then None else Some (rm st.installed_roots)) - ~reinstall:(rm (Lazy.force st.reinstall)) + ~reinstall:(rm (OpamLazy.force st.reinstall)) in let has_setenv = match OpamStd.Option.map OpamFile.OPAM.env (OpamSwitchState.opam_opt st nv) diff --git a/src/state/opamSwitchAction.mli b/src/state/opamSwitchAction.mli index 66b86e70ca7..df113dca2b9 100644 --- a/src/state/opamSwitchAction.mli +++ b/src/state/opamSwitchAction.mli @@ -56,6 +56,7 @@ val add_to_reinstall: given newly installed package. The updated state is written to disk unless [OpamStateConfig.(!r.dry_run)] and returned. *) val add_to_installed: + task_pool:Domainslib.Task.pool -> rw switch_state -> ?root:bool -> package -> rw switch_state (** Updates the package selections and switch config to take into account the @@ -63,7 +64,7 @@ val add_to_installed: [OpamStateConfig.(!r.dry_run)], and returned. If [keep_as_root], the package isn't removed from the switch state [installed_roots] set. *) val remove_from_installed: - ?keep_as_root:bool -> rw switch_state -> package -> rw switch_state + ?keep_as_root:bool -> task_pool:Domainslib.Task.pool -> rw switch_state -> package -> rw switch_state (** Update the switch selections with the supplied optional arguments. Changes are written to disk and returned *) @@ -72,4 +73,5 @@ val update_switch_state: ?installed_roots: package_set -> ?reinstall: package_set -> ?pinned: package_set -> + task_pool:Domainslib.Task.pool -> rw switch_state -> rw switch_state diff --git a/src/state/opamSwitchState.ml b/src/state/opamSwitchState.ml index 1f1649062b2..18c08a6c499 100644 --- a/src/state/opamSwitchState.ml +++ b/src/state/opamSwitchState.ml @@ -12,6 +12,7 @@ open OpamTypes open OpamStd.Op open OpamPackage.Set.Op +open Domainslib let log ?level fmt = OpamConsole.log ?level "STATE" fmt let slog = OpamConsole.slog @@ -157,7 +158,7 @@ let infer_switch_invariant st = st.installed else st.compiler_packages in - let lazy available_packages = st.available_packages in + let available_packages = OpamLazy.force st.available_packages in infer_switch_invariant_raw st.switch_global st.switch st.switch_config st.opams st.packages compiler_packages st.installed_roots available_packages @@ -338,7 +339,7 @@ let load lock_kind gt rt switch = OpamPackage.Map.union (fun _ x -> x) repos_package_index pinned_opams in let available_packages = - lazy (compute_available_and_pinned_packages gt switch switch_config + OpamLazy.create (fun () ->compute_available_and_pinned_packages gt switch switch_config ~pinned ~opams) in let opams = @@ -367,7 +368,7 @@ let load lock_kind gt rt switch = "No definition found for the following installed packages: %s\n\ This switch may need to be reinstalled" (OpamPackage.Set.to_string installed_without_def); - let changed = lazy ( + let changed = OpamLazy.create (fun () -> (* Note: This doesn't detect changed _dev_ packages, since it's based on the metadata or the archive hash changing and they don't have an archive hash. Therefore, dev package update needs to add to the reinstall file *) @@ -389,7 +390,7 @@ let load lock_kind gt rt switch = | Some invariant -> switch_config, invariant | None -> let available_packages = - let lazy (available_packages, pinned) = available_packages in + let available_packages, pinned = OpamLazy.force available_packages in OpamPackage.Set.union available_packages @@ filter_available_packages gt switch switch_config ~opams:pinned in @@ -457,10 +458,10 @@ let load lock_kind gt rt switch = OpamPackage.Name.Map.empty conf_files in - let ext_files_changed = lazy ( + let ext_files_changed = OpamLazy.create (fun () -> OpamPackage.Name.Map.fold (fun name conf acc -> let nv = OpamPackage.package_of_name installed name in - let path = lazy ( + let path = OpamLazy.create (fun () -> OpamStd.Sys.split_path_variable (OpamStd.Env.get "PATH") |> List.map OpamFilename.Dir.of_string ) in @@ -492,7 +493,7 @@ let load lock_kind gt rt switch = OpamFilename.is_exec file && let dirname = OpamFilename.dirname file in not @@ List.exists (OpamFilename.Dir.equal dirname) - (Lazy.force path) + (OpamLazy.force path) in if exec_not_in_path then OpamConsole.warning @@ -508,15 +509,15 @@ let load lock_kind gt rt switch = OpamPackage.Set.empty ) in (* depext check *) - let available_packages = OpamCompat.Lazy.map fst available_packages in + let available_packages = OpamLazy.map fst available_packages in let sys_packages = if not (OpamFile.Config.depext gt.config) - || OpamStateConfig.(!r.no_depexts) then - lazy OpamPackage.Map.empty - else lazy ( + || OpamStateConfig.(!r.no_depexts) + then OpamLazy.create (fun () -> OpamPackage.Map.empty) + else OpamLazy.create (fun () -> depexts_status_of_packages_raw gt.config switch_config ~env:gt.global_variables - (Lazy.force available_packages) + (OpamLazy.force available_packages) ~depexts:(fun package -> let env = OpamPackageVar.resolve_switch_raw ~package gt switch switch_config @@ -526,20 +527,20 @@ let load lock_kind gt rt switch = in let available_packages = if not (OpamFile.Config.depext gt.config) then available_packages - else lazy ( - let sys_packages = Lazy.force sys_packages in + else OpamLazy.create (fun () -> + let sys_packages = OpamLazy.force sys_packages in OpamPackage.Set.filter (fun nv -> depexts_unavailable_raw sys_packages nv = None) - (Lazy.force available_packages) + (OpamLazy.force available_packages) ) in - let sys_packages_changed = lazy ( + let sys_packages_changed = OpamLazy.create (fun () -> let sys_packages = OpamPackage.Map.filter (fun pkg spkg -> OpamPackage.Set.mem pkg installed && not (OpamSysPkg.Set.is_empty spkg.OpamSysPkg.s_available && OpamSysPkg.Set.is_empty spkg.OpamSysPkg.s_not_found)) - (Lazy.force sys_packages) + (OpamLazy.force sys_packages) in if OpamPackage.Map.is_empty sys_packages then OpamPackage.Set.empty @@ -585,23 +586,23 @@ let load lock_kind gt rt switch = (OpamPackage.Map.bindings missing_map))); changed ) in - let available_packages = lazy ( + let available_packages = OpamLazy.create (fun () -> let chrono = OpamConsole.timer () in - let r = Lazy.force available_packages in + let r = OpamLazy.force available_packages in log ~level:2 "Availability of packages computed in %.3fs." (chrono ()); r ) in - let reinstall = lazy ( + let reinstall = OpamLazy.create (fun () -> OpamFile.PkgList.safe_read (OpamPath.Switch.reinstall gt.root switch) ++ - Lazy.force changed ++ - (Lazy.force ext_files_changed %% Lazy.force available_packages) ++ - Lazy.force sys_packages_changed + OpamLazy.force changed ++ + (OpamLazy.force ext_files_changed %% OpamLazy.force available_packages) ++ + OpamLazy.force sys_packages_changed ) in - let invalidated = lazy ( - Lazy.force changed ++ - Lazy.force ext_files_changed ++ - Lazy.force sys_packages_changed - -- Lazy.force available_packages + let invalidated = OpamLazy.create (fun () -> + OpamLazy.force changed ++ + OpamLazy.force ext_files_changed ++ + OpamLazy.force sys_packages_changed + -- OpamLazy.force available_packages ) in let st = { switch_global = (gt :> unlocked global_state); @@ -625,7 +626,7 @@ let load_virtual ?repos_list ?(avail_default=true) gt rt = OpamRepositoryState.build_index rt repos_list in let packages = OpamPackage.keys opams in - let available_packages = lazy ( + let available_packages = OpamLazy.create (fun () -> OpamPackage.Map.filter (fun _ opam -> OpamFilter.eval_to_bool ~default:avail_default (OpamPackageVar.resolve_global gt) @@ -652,10 +653,10 @@ let load_virtual ?repos_list ?(avail_default=true) gt rt = opams; conf_files = OpamPackage.Name.Map.empty; packages; - sys_packages = lazy OpamPackage.Map.empty; + sys_packages = OpamLazy.create (fun () -> OpamPackage.Map.empty); available_packages; - reinstall = lazy OpamPackage.Set.empty; - invalidated = lazy (OpamPackage.Set.empty); + reinstall = OpamLazy.create (fun () -> OpamPackage.Set.empty); + invalidated = OpamLazy.create (fun () -> OpamPackage.Set.empty); } let selections st = @@ -733,7 +734,7 @@ let packages_of_atoms st atoms = OpamFormula.packages_of_atoms st.packages atoms let get_package st name = try OpamPinned.package st name with Not_found -> try find_installed_package_by_name st name with Not_found -> - try OpamPackage.max_version (Lazy.force st.available_packages) name + try OpamPackage.max_version (OpamLazy.force st.available_packages) name with Not_found -> OpamPackage.max_version st.packages name @@ -776,7 +777,7 @@ let depexts_status_of_packages st set = ~env:st.switch_global.global_variables ~depexts:(depexts st) let depexts_unavailable st nv = - depexts_unavailable_raw (Lazy.force st.sys_packages) nv + depexts_unavailable_raw (OpamLazy.force st.sys_packages) nv let dev_packages st = OpamPackage.Set.filter (is_dev_package st) @@ -909,7 +910,7 @@ let package_env_t st ~force_dev_deps ~test ~doc ~dev_setup (OpamVariable.Full.to_string v) (OpamPackage.to_string nv); r -let get_dependencies_t st ~force_dev_deps ~test ~doc ~dev_setup +let get_dependencies_t st ~task_pool:_ ~force_dev_deps ~test ~doc ~dev_setup ~requested_allpkgs deps opams = let filter_undefined nv = OpamFormula.map (fun (name, fc) -> @@ -941,12 +942,13 @@ let universe st ?(dev_setup=OpamStateConfig.(!r.dev_setup)) ?(force_dev_deps=false) ?reinstall + ~task_pool ~requested user_action = let chrono = OpamConsole.timer () in - let names = OpamPackage.names_of_packages requested in let requested_allpkgs = - OpamPackage.packages_of_names st.packages names + let names = OpamPackage.names_of_packages requested in + OpamPackage.packages_of_names st.packages names in let env = package_env_t st @@ -954,30 +956,38 @@ let universe st ~requested_allpkgs in let get_deps = - get_dependencies_t st + let f = get_dependencies_t st ~task_pool ~force_dev_deps ~test ~doc ~dev_setup - ~requested_allpkgs + ~requested_allpkgs:requested_allpkgs in + f in - let u_depends = - let depend = - let ignored = OpamStateConfig.(!r.ignore_constraints_on) in - if OpamPackage.Name.Set.is_empty ignored then OpamFile.OPAM.depends - else fun opam -> - OpamFormula.map (fun (name, cstr as atom) -> - if OpamPackage.Name.Set.mem name ignored then - let cstr = - OpamFormula.map - (function Constraint _ -> Empty | Filter _ as f -> Atom f) - cstr - in - Atom (name, cstr) - else Atom atom) - (OpamFile.OPAM.depends opam) - in - get_deps depend st.opams + let u_depends_prom = + Task.async task_pool (fun () -> + let depend = + let ignored = OpamStateConfig.(!r.ignore_constraints_on) in + if OpamPackage.Name.Set.is_empty ignored then OpamFile.OPAM.depends + else fun opam -> + OpamFormula.map (fun (name, cstr as atom) -> + if OpamPackage.Name.Set.mem name ignored then + let cstr = + OpamFormula.map + (function Constraint _ -> Empty | Filter _ as f -> Atom f) + cstr + in + Atom (name, cstr) + else Atom atom) + (OpamFile.OPAM.depends opam) + in + get_deps depend st.opams) + in + let u_depopts_prom = + Task.async task_pool (fun () -> + get_deps OpamFile.OPAM.depopts st.opams) + in + let u_conflicts_prom = + Task.async task_pool (fun () -> + get_conflicts st st.packages st.opams) in - let u_depopts = get_deps OpamFile.OPAM.depopts st.opams in - let u_conflicts = get_conflicts st st.packages st.opams in let u_invariant = if OpamStateConfig.(!r.unlock_base) then OpamFormula.Empty else st.switch_invariant @@ -988,11 +998,13 @@ let universe st would be much more involved, but some solvers might struggle without any cleanup at this point *) (* remove_conflicts st base *) - (Lazy.force st.available_packages) + (OpamLazy.force st.available_packages) in - let u_reinstall = + let u_reinstall_prom = Task.async task_pool (fun () -> (* Ignore reinstalls outside of the dependency cone of [requested_allpkgs] *) + let u_depopts = Task.await task_pool (u_depopts_prom) in + let u_depends = Task.await task_pool (u_depends_prom) in let resolve_deps nv = OpamPackageVar.filter_depends_formula ~build:true ~post:true ~default:true ~env:(env nv) @@ -1001,39 +1013,37 @@ let universe st |> OpamFormula.packages st.packages in let requested_deps = - OpamPackage.Set.fixpoint resolve_deps requested_allpkgs + OpamPackage.Set.parallel_fixpoint ~task_pool resolve_deps requested_allpkgs in - requested_deps %% Lazy.force st.reinstall ++ + requested_deps %% OpamLazy.force st.reinstall ++ match reinstall with | Some set -> set - | None -> OpamPackage.Set.empty + | None -> OpamPackage.Set.empty) in - let missing_depexts = + let missing_depexts_prom = Task.async task_pool (fun () -> OpamPackage.Map.fold (fun nv status acc -> if OpamSysPkg.Set.is_empty status.OpamSysPkg.s_available then acc else OpamPackage.Set.add nv acc) - (Lazy.force st.sys_packages) - OpamPackage.Set.empty - in - let avoid_versions = - OpamPackage.Set.filter (avoid_version st) u_available + (OpamLazy.force st.sys_packages) + OpamPackage.Set.empty) in + let avoid_versions = OpamPackage.Set.filter (avoid_version st) u_available in let u = { u_packages = st.packages; u_action = user_action; u_installed = st.installed; - u_available; - u_depends; - u_depopts; - u_conflicts; + u_available = u_available; + u_depends = Task.await task_pool u_depends_prom; + u_depopts = Task.await task_pool u_depopts_prom; + u_conflicts = Task.await task_pool u_conflicts_prom; u_installed_roots = st.installed_roots; u_pinned = OpamPinned.packages st; u_invariant; - u_reinstall; + u_reinstall = Task.await task_pool u_reinstall_prom; u_attrs = ["opam-query", requested; - "missing-depexts", missing_depexts; + "missing-depexts", (Task.await task_pool missing_depexts_prom); "avoid-version", avoid_versions]; } in @@ -1049,8 +1059,8 @@ let dump_pef_state st oc = (* let root = OpamPackage.Set.mem nv st.installed_roots in *) let inv = OpamPackage.Set.mem nv st.compiler_packages in let pinned = OpamPackage.Set.mem nv st.pinned in - let available = OpamPackage.Set.mem nv (Lazy.force st.available_packages) in - let reinstall = OpamPackage.Set.mem nv (Lazy.force st.reinstall) in + let available = OpamPackage.Set.mem nv (OpamLazy.force st.available_packages) in + let reinstall = OpamPackage.Set.mem nv (OpamLazy.force st.reinstall) in let dev = OpamPackageVar.is_dev_package st opam in (* current state *) Printf.fprintf oc "available: %b\n" available; @@ -1144,9 +1154,9 @@ let unavailable_reason_raw st (name, vformula) = else ", e.g. ") (OpamFilter.to_string avail)) else if OpamPackage.has_name - (Lazy.force st.available_packages -- + (OpamLazy.force st.available_packages -- remove_conflicts st st.compiler_packages - (Lazy.force st.available_packages)) + (OpamLazy.force st.available_packages)) name then `ConflictsBase else if OpamPackage.has_name st.compiler_packages name && @@ -1204,21 +1214,21 @@ let update_package_metadata nv opam st = { st with opams = OpamPackage.Map.add nv opam st.opams; packages = OpamPackage.Set.add nv st.packages; - available_packages = lazy ( + available_packages = OpamLazy.create (fun () -> if OpamFilter.eval_to_bool ~default:false (OpamPackageVar.resolve_switch_raw ~package:nv st.switch_global st.switch st.switch_config) (OpamFile.OPAM.available opam) - then OpamPackage.Set.add nv (Lazy.force st.available_packages) - else OpamPackage.Set.remove nv (Lazy.force st.available_packages) + then OpamPackage.Set.add nv (OpamLazy.force st.available_packages) + else OpamPackage.Set.remove nv (OpamLazy.force st.available_packages) ); - reinstall = lazy - (match OpamPackage.Map.find_opt nv st.installed_opams with + reinstall = OpamLazy.create + (fun () -> match OpamPackage.Map.find_opt nv st.installed_opams with | Some inst -> if OpamFile.OPAM.effectively_equal inst opam - then OpamPackage.Set.remove nv (Lazy.force st.reinstall) - else OpamPackage.Set.add nv (Lazy.force st.reinstall) - | _ -> Lazy.force st.reinstall); + then OpamPackage.Set.remove nv (OpamLazy.force st.reinstall) + else OpamPackage.Set.add nv (OpamLazy.force st.reinstall) + | _ -> OpamLazy.force st.reinstall); } let remove_package_metadata nv st = @@ -1226,7 +1236,7 @@ let remove_package_metadata nv st = opams = OpamPackage.Map.remove nv st.opams; packages = OpamPackage.Set.remove nv st.packages; available_packages = - lazy (OpamPackage.Set.remove nv (Lazy.force st.available_packages)); + OpamLazy.create (fun () -> OpamPackage.Set.remove nv (OpamLazy.force st.available_packages)); } let update_pin nv opam st = @@ -1237,8 +1247,8 @@ let update_pin nv opam st = let pinned = OpamPackage.Set.add nv (OpamPackage.filter_name_out st.pinned nv.name) in - let available_packages = lazy ( - OpamPackage.filter_name_out (Lazy.force st.available_packages) nv.name + let available_packages = OpamLazy.create (fun () -> + OpamPackage.filter_name_out (OpamLazy.force st.available_packages) nv.name ) in let st = update_package_metadata nv opam { st with pinned; available_packages } @@ -1246,14 +1256,14 @@ let update_pin nv opam st = if not (OpamFile.Config.depext st.switch_global.config) || OpamSysPkg.Set.is_empty (depexts st nv) then st else - let sys_packages = lazy ( + let sys_packages = OpamLazy.create (fun () -> OpamPackage.Map.union (fun _ n -> n) - (Lazy.force st.sys_packages) + (OpamLazy.force st.sys_packages) (depexts_status_of_packages st (OpamPackage.Set.singleton nv)) ) in - let available_packages = lazy ( + let available_packages = OpamLazy.create (fun () -> OpamPackage.Set.filter (fun nv -> depexts_unavailable st nv = None) - (Lazy.force st.available_packages) + (OpamLazy.force st.available_packages) ) in { st with sys_packages; available_packages } @@ -1332,14 +1342,14 @@ let dependencies_filter_to_formula_t ~build ~post st nv = in OpamFilter.filter_formula ~default:true env -let dependencies_t st base_deps_compute deps_compute +let dependencies_t st base_deps_compute deps_compute ~task_pool ~depopts ~installed ?(unavailable=false) packages = if OpamPackage.Set.is_empty packages then OpamPackage.Set.empty else let base = packages ++ if installed then st.installed else if unavailable then st.packages - else Lazy.force st.available_packages + else OpamLazy.force st.available_packages in log ~level:3 "dependencies packages=%a" (slog OpamPackage.Set.to_string) packages; @@ -1348,6 +1358,7 @@ let dependencies_t st base_deps_compute deps_compute let filter = base_deps_compute base in let get_deps = get_dependencies_t st + ~task_pool ~force_dev_deps:false ~test:false ~doc:false ~dev_setup:false ~requested_allpkgs:packages in @@ -1375,8 +1386,8 @@ let dependencies_t st base_deps_compute deps_compute (slog OpamPackage.Set.to_string) result; result -let dependencies st ~build ~post = - dependencies_t st +let dependencies st ~task_pool ~build ~post = + dependencies_t st ~task_pool (fun base nv ff -> if OpamPackage.Set.mem nv base then Some ff else None) (fun base base_depends packages -> @@ -1400,8 +1411,8 @@ let dependencies st ~build ~post = in aux packages packages) -let reverse_dependencies st ~build ~post = - dependencies_t st +let reverse_dependencies st ~task_pool ~build ~post = + dependencies_t st ~task_pool (fun base nv ff -> if OpamPackage.Set.mem nv base then Some (dependencies_filter_to_formula_t ~build ~post st nv ff) @@ -1467,17 +1478,17 @@ let reverse_dependencies st ~build ~post = let invariant_root_packages st = OpamPackage.Set.filter (OpamFormula.verifies st.switch_invariant) st.installed -let compute_invariant_packages st = +let compute_invariant_packages ~task_pool st = let pkgs = invariant_root_packages st in - dependencies ~build:false ~post:true ~depopts:false ~installed:true + dependencies ~task_pool ~build:false ~post:true ~depopts:false ~installed:true ~unavailable:false st pkgs -let compiler_packages st = +let compiler_packages ~task_pool st = let compiler_packages = OpamPackage.Set.filter (fun nv -> try OpamFile.OPAM.has_flag Pkgflag_Compiler (opam st nv) with Not_found -> false) st.installed in - dependencies ~build:true ~post:false ~depopts:true ~installed:true + dependencies ~task_pool ~build:true ~post:false ~depopts:true ~installed:true ~unavailable:false st compiler_packages diff --git a/src/state/opamSwitchState.mli b/src/state/opamSwitchState.mli index 186cd45da10..9cd735decaa 100644 --- a/src/state/opamSwitchState.mli +++ b/src/state/opamSwitchState.mli @@ -174,12 +174,12 @@ val depexts: 'a switch_state -> package -> OpamSysPkg.Set.t [unavaiable]: also consider unavailable packages *) val dependencies: - 'a switch_state -> build:bool -> post:bool -> depopts:bool -> + 'a switch_state -> task_pool:Domainslib.Task.pool -> build:bool -> post:bool -> depopts:bool -> installed:bool -> ?unavailable:bool -> package_set -> package_set (** Same as [dependencies] but for reverse dependencies. *) val reverse_dependencies: - 'a switch_state -> build:bool -> post:bool -> depopts:bool -> + 'a switch_state -> task_pool:Domainslib.Task.pool -> build:bool -> post:bool -> depopts:bool -> installed:bool -> ?unavailable:bool -> package_set -> package_set (** Returns required system packages of each of the given packages (elements are @@ -210,6 +210,7 @@ val universe: ?dev_setup:bool -> ?force_dev_deps:bool -> ?reinstall:package_set -> + task_pool:Domainslib.Task.pool -> requested:package_set -> user_action -> universe @@ -248,11 +249,11 @@ val update_repositories: val invariant_root_packages: 'a switch_state -> package_set (* Compute installed invariant dependency cone *) -val compute_invariant_packages: 'a switch_state -> package_set +val compute_invariant_packages: task_pool:Domainslib.Task.pool -> 'a switch_state -> package_set (* Returns set of packages of installed compiler packages and their dependencies (only build & depopts) *) -val compiler_packages: 'a switch_state -> package_set +val compiler_packages: task_pool:Domainslib.Task.pool -> 'a switch_state -> package_set (** {2 User interaction and reporting } *) diff --git a/src/state/opamSysInteract.ml b/src/state/opamSysInteract.ml index 262aab4aa74..82e1748880a 100644 --- a/src/state/opamSysInteract.ml +++ b/src/state/opamSysInteract.ml @@ -241,9 +241,9 @@ module Cygwin = struct let internal_cygwin = let internal = - Lazy.from_fun @@ fun () -> (OpamStateConfig.(!r.root_dir) / ".cygwin") + OpamLazy.from_fun (fun () -> (OpamStateConfig.(!r.root_dir) / ".cygwin")) in - fun () -> Lazy.force internal + fun () -> OpamLazy.force internal let internal_cygroot () = internal_cygwin () / "root" let internal_cygcache () = internal_cygwin () / "cache" let cygsetup () = internal_cygwin () // setupexe @@ -379,14 +379,14 @@ module Cygwin = struct OpamProcess.Job.run @@ download_setupexe dst) end -let yum_cmd = lazy begin - if OpamSystem.resolve_command "yum" <> None then - "yum" - else if OpamSystem.resolve_command "dnf" <> None then - "dnf" - else - raise (OpamSystem.Command_not_found "yum or dnf") -end +let yum_cmd = + OpamLazy.create (fun () -> + if OpamSystem.resolve_command "yum" <> None then + "yum" + else if OpamSystem.resolve_command "dnf" <> None then + "dnf" + else + raise (OpamSystem.Command_not_found "yum or dnf")) let packages_status ?(env=OpamVariable.Map.empty) config packages = let (+++) pkg set = OpamSysPkg.Set.add (OpamSysPkg.of_string pkg) set in @@ -933,11 +933,11 @@ let install_packages_commands_t ?(env=OpamVariable.Map.empty) config sys_package let epel_release = "epel-release" in let install_epel rest = if List.mem epel_release packages then - [`AsAdmin (Lazy.force yum_cmd), "install"::yes ["-y"] [epel_release]] @ rest + [`AsAdmin (OpamLazy.force yum_cmd), "install"::yes ["-y"] [epel_release]] @ rest else rest in install_epel - [`AsAdmin (Lazy.force yum_cmd), "install"::yes ["-y"] + [`AsAdmin (OpamLazy.force yum_cmd), "install"::yes ["-y"] (OpamStd.String.Set.of_list packages |> OpamStd.String.Set.remove epel_release |> OpamStd.String.Set.elements); @@ -1039,7 +1039,7 @@ let update ?(env=OpamVariable.Map.empty) config = match family ~env () with | Alpine -> Some (`AsAdmin "apk", ["update"]) | Arch -> Some (`AsAdmin "pacman", ["-Sy"]) - | Centos -> Some (`AsAdmin (Lazy.force yum_cmd), ["makecache"]) + | Centos -> Some (`AsAdmin (OpamLazy.force yum_cmd), ["makecache"]) | Cygwin -> None | Debian -> Some (`AsAdmin "apt-get", ["update"]) | Dummy test -> diff --git a/src/state/opamSysPoll.ml b/src/state/opamSysPoll.ml index 2930d973d77..fe43b5ed054 100644 --- a/src/state/opamSysPoll.ml +++ b/src/state/opamSysPoll.ml @@ -50,7 +50,7 @@ let poll_arch () = match raw with | None | Some "" -> None | Some a -> Some (normalise_arch a) -let arch = Lazy.from_fun poll_arch +let arch = OpamLazy.from_fun poll_arch let normalise_os raw = match String.lowercase_ascii raw with @@ -66,10 +66,10 @@ let poll_os () = match raw with | None | Some "" -> None | Some s -> Some (normalise_os s) -let os = Lazy.from_fun poll_os +let os = OpamLazy.from_fun poll_os let os_release_field = - let os_release_file = lazy ( + let os_release_file = OpamLazy.create (fun () -> List.find Sys.file_exists ["/etc/os-release"; "/usr/lib/os-release"] |> OpamProcess.read_lines |> OpamStd.List.filter_map (fun s -> @@ -83,16 +83,16 @@ let os_release_field = with Scanf.Scan_failure _ | End_of_file -> None) ) in fun f -> - try Some (OpamStd.List.assoc String.equal f (Lazy.force os_release_file)) + try Some (OpamStd.List.assoc String.equal f (OpamLazy.force os_release_file)) with Not_found -> None let is_android, android_release = - let prop = lazy (command_output ["getprop"; "ro.build.version.release"]) in - (fun () -> Lazy.force prop <> None), - (fun () -> Lazy.force prop) + let prop = OpamLazy.create (fun () -> command_output ["getprop"; "ro.build.version.release"]) in + (fun () -> OpamLazy.force prop <> None), + (fun () -> OpamLazy.force prop) let poll_os_distribution () = - let lazy os = os in + let os = OpamLazy.force os in match os with | Some "macos" as macos -> if OpamSystem.resolve_command "brew" <> None then Some "homebrew" @@ -123,10 +123,10 @@ let poll_os_distribution () = in if cygwin then Some "cygwin" else os | os -> os -let os_distribution = Lazy.from_fun poll_os_distribution +let os_distribution = OpamLazy.from_fun poll_os_distribution let poll_os_version () = - let lazy os = os in + let os = OpamLazy.force os in match os with | Some "linux" -> android_release () >>= norm >>+ fun () -> @@ -146,25 +146,25 @@ let poll_os_version () = OpamStd.Sys.uname "-U" >>= norm | _ -> OpamStd.Sys.uname "-r" >>= norm -let os_version = Lazy.from_fun poll_os_version +let os_version = OpamLazy.from_fun poll_os_version let poll_os_family () = - let lazy os = os in + let os = OpamLazy.force os in match os with | Some "linux" -> (os_release_field "ID_LIKE" >>= fun s -> Scanf.sscanf s " %s" norm (* first word *)) - ++ Lazy.force os_distribution + ++ OpamLazy.force os_distribution | Some ("freebsd" | "openbsd" | "netbsd" | "dragonfly") -> Some "bsd" | Some ("win32" | "cygwin") -> Some "windows" - | _ -> Lazy.force os_distribution -let os_family = Lazy.from_fun poll_os_family + | _ -> OpamLazy.force os_distribution +let os_family = OpamLazy.from_fun poll_os_family let variables = List.map (fun (n, v) -> OpamVariable.of_string n, - OpamCompat.Lazy.map (OpamStd.Option.map (fun v -> OpamTypes.S v)) v) + OpamLazy.map (OpamStd.Option.map (fun v -> OpamTypes.S v)) v) [ "arch", arch; "os", os; @@ -174,8 +174,7 @@ let variables = ] let cores = - let v = Lazy.from_fun OpamSystem.cpu_count in - fun () -> Lazy.force v + OpamSystem.cpu_count_memo (* Exported functions *) let resolve_or_poll var poll env = @@ -183,8 +182,12 @@ let resolve_or_poll var poll env = | Some (S c) -> Some c | _ -> match OpamVariable.Map.find_opt (OpamVariable.of_string var) env with - | Some (lazy (Some (OpamTypes.S c)), _) -> Some c - | _ -> Lazy.force poll + (* | Some (lazy (Some (OpamTypes.S c)), _) -> Some c *) + | Some (lazyval, _) -> + (match OpamLazy.force lazyval with + | Some (OpamTypes.S c) -> Some c + | _ -> OpamLazy.force poll) + | _ -> OpamLazy.force poll let arch = resolve_or_poll "arch" arch let os = resolve_or_poll "os" os diff --git a/src/state/opamSysPoll.mli b/src/state/opamSysPoll.mli index 48de7259f23..01b5469beb4 100644 --- a/src/state/opamSysPoll.mli +++ b/src/state/opamSysPoll.mli @@ -21,7 +21,7 @@ val os_distribution: gt_variables -> string option val os_version: gt_variables -> string option val os_family: gt_variables -> string option -val variables: (OpamVariable.t * OpamTypes.variable_contents option Lazy.t) list +val variables: (OpamVariable.t * OpamTypes.variable_contents option OpamLazy.t) list (** The function used internally to get our canonical names for architectures (returns its input lowercased if not a recognised arch). This is typically diff --git a/src/state/opamUpdate.ml b/src/state/opamUpdate.ml index 515a8d06454..6be1370225e 100644 --- a/src/state/opamUpdate.ml +++ b/src/state/opamUpdate.ml @@ -141,7 +141,7 @@ let repository rt repo = (if OpamFilename.exists_dir local_dir then (* Mark the obsolete local directory for deletion once we complete: it's no longer needed once we have a tar.gz *) - Hashtbl.add rt.repos_tmp repo.repo_name (lazy local_dir)) + Hashtbl.add rt.repos_tmp repo.repo_name (OpamLazy.create (fun () -> local_dir))) else if OpamFilename.exists tarred_repo then (OpamFilename.move_dir ~src:repo_root ~dst:local_dir; OpamFilename.remove tarred_repo); @@ -489,7 +489,7 @@ let pinned_packages st ?autolock ?(working_dir=OpamPackage.Name.Set.empty) names in let st_update, updates = OpamParallel.reduce - ~jobs:(Lazy.force OpamStateConfig.(!r.jobs)) + ~jobs:(OpamLazy.force OpamStateConfig.(!r.jobs)) ~command ~merge ~nil:((fun st -> st), OpamPackage.Name.Set.empty) diff --git a/src_ext/patches/dose3.common/dose3.patch b/src_ext/patches/dose3.common/dose3.patch new file mode 100644 index 00000000000..d75190f6781 --- /dev/null +++ b/src_ext/patches/dose3.common/dose3.patch @@ -0,0 +1,743 @@ +diff -ru dose3.old/src/algo/depsolver.ml dose3/src/algo/depsolver.ml +--- dose3.old/src/algo/depsolver.ml 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/algo/depsolver.ml 2024-03-09 16:53:16.854662398 -0800 +@@ -13,6 +13,7 @@ + open ExtLib + open Dose_common + open CudfAdd ++open Domainslib + + include Util.Logging (struct + let label = "dose_algo.depsolver" +@@ -24,20 +25,20 @@ + + let timer_init = Util.Timer.create "Algo.Depsolver.init" + +-let load ?(global_constraints = []) universe = ++let load ?(global_constraints = []) ~task_pool universe = + let global_constraints = + List.map + (fun (vpkg, l) -> (vpkg, List.map (CudfAdd.pkgtoint universe) l)) + global_constraints + in +- Depsolver_int.init_solver_univ ~global_constraints universe ++ Depsolver_int.init_solver_univ ~task_pool ~global_constraints universe + + (** [univcheck ?callback universe] check all packages in the + universe for installability + + @return the number of packages that cannot be installed + *) +-let univcheck ?(global_constraints = []) ?callback ?(explain = true) universe = ++let univcheck ?(global_constraints = []) ?callback ?(explain = true) ~task_pool universe = + let aux ?callback univ = + let global_constraints = + List.map +@@ -46,7 +47,7 @@ + in + Util.Timer.start timer_init ; + let solver = +- Depsolver_int.init_solver_univ ~global_constraints ~explain univ ++ Depsolver_int.init_solver_univ ~task_pool ~global_constraints ~explain univ + in + Util.Timer.stop timer_init () ; + Util.Timer.start timer_solver ; +@@ -82,7 +83,7 @@ + @param pkglist list of packages to be checked + @return the number of packages that cannot be installed + *) +-let listcheck ?(global_constraints = []) ?callback ?(explain = true) universe ++let listcheck ?(global_constraints = []) ?callback ?(explain = true) ~task_pool universe + pkglist = + let aux ?callback univ idlist = + let global_constraints = +@@ -92,7 +93,7 @@ + in + Util.Timer.start timer_init ; + let solver = +- Depsolver_int.init_solver_univ ~global_constraints ~explain univ ++ Depsolver_int.init_solver_univ ~global_constraints ~explain ~task_pool univ + in + Util.Timer.stop timer_init () ; + Util.Timer.start timer_solver ; +@@ -125,7 +126,7 @@ + in + aux ~callback:callback_int universe idlist + +-let univcheck_lowmem ?(global_constraints = []) ?callback ?(explain = true) ++let univcheck_lowmem ?(global_constraints = []) ?callback ?(explain = true) ~task_pool + universe = + let pkglist = Cudf.get_packages universe in + let keeplist = List.flatten (List.map snd global_constraints) in +@@ -177,52 +178,54 @@ + let l = CudfAdd.Cudf_set.elements su in + let u = Cudf.load_universe l in + let pkglist = CudfAdd.Cudf_set.elements stt in +- let b = listcheck ~global_constraints ?callback ~explain u pkglist in ++ let b = listcheck ~global_constraints ?callback ~explain ~task_pool u pkglist in + b + acc) + 0 + (partitions keepset pkglist) + +-let edos_install_cache univ cudfpool pkglist = ++let edos_install_cache ~task_pool univ cudfpool pkglist = + let idlist = List.map (CudfAdd.pkgtoint univ) pkglist in + let closure = Depsolver_int.dependency_closure_cache cudfpool idlist in + let solver = +- Depsolver_int.init_solver_closure ~global_constraints:[] cudfpool closure ++ Depsolver_int.init_solver_closure ~task_pool ~global_constraints:[] cudfpool closure + in + let res = Depsolver_int.solve solver ~explain:true idlist in + Diagnostic.diagnosis solver.Depsolver_int.map univ res idlist + +-let edos_install ?(global_constraints = []) universe pkg = ++let edos_install ?(global_constraints = []) ~task_pool universe pkg = + let global_constraints = + List.map + (fun (vpkg, l) -> (vpkg, List.map (CudfAdd.pkgtoint universe) l)) + global_constraints + in +- let cudfpool = Depsolver_int.init_pool_univ ~global_constraints universe in +- edos_install_cache universe cudfpool [pkg] ++ let cudfpool = Depsolver_int.init_pool_univ ~task_pool ~global_constraints universe in ++ edos_install_cache ~task_pool universe cudfpool [pkg] + +-let edos_coinstall ?(global_constraints = []) universe pkglist = ++let num_domains = 16 ++ ++let edos_coinstall ?(global_constraints = []) ~task_pool universe pkglist = + let global_constraints = + List.map + (fun (vpkg, l) -> (vpkg, List.map (CudfAdd.pkgtoint universe) l)) + global_constraints + in +- let cudfpool = Depsolver_int.init_pool_univ ~global_constraints universe in +- edos_install_cache universe cudfpool pkglist ++ let cudfpool = Depsolver_int.init_pool_univ ~task_pool ~global_constraints universe in ++ edos_install_cache ~task_pool universe cudfpool pkglist + +-let edos_coinstall_prod ?(global_constraints = []) universe ll = ++let edos_coinstall_prod ?(global_constraints = []) ~task_pool universe ll = + let global_constraints = + List.map + (fun (vpkg, l) -> (vpkg, List.map (CudfAdd.pkgtoint universe) l)) + global_constraints + in +- let cudfpool = Depsolver_int.init_pool_univ ~global_constraints universe in ++ let cudfpool = Depsolver_int.init_pool_univ ~task_pool ~global_constraints universe in + let return a = [a] in + let bind m f = List.flatten (List.map f m) in + let rec permutation = function + | [] -> return [] + | h :: t -> bind (permutation t) (fun t1 -> List.map (fun h1 -> h1 :: t1) h) + in +- List.map (edos_install_cache universe cudfpool) (permutation ll) ++ List.map (edos_install_cache ~task_pool universe cudfpool) (permutation ll) + + let is_consistent univ = + match Cudf_checker.is_consistent univ with +@@ -331,7 +334,7 @@ + @param universe the package universe + @param pkglist a subset of [universe] + *) +-let dependency_closure ?(global_constraints = []) ?maxdepth ?conjunctive ++let dependency_closure ?(global_constraints = []) ?maxdepth ?conjunctive ~task_pool + universe pkglist = + let global_constraints = + List.map +@@ -342,7 +345,7 @@ + let l = List.map (CudfAdd.pkgtoint universe) pkglist in + List.flatten (List.map snd global_constraints) @ l + in +- let pool = Depsolver_int.init_pool_univ ~global_constraints universe in ++ let pool = Depsolver_int.init_pool_univ ~task_pool ~global_constraints universe in + let l = + Depsolver_int.dependency_closure_cache ?maxdepth ?conjunctive pool idlist + in +@@ -373,14 +376,14 @@ + + type enc = Cnf | Dimacs + +-let output_clauses ?(global_constraints = []) ?(enc = Cnf) universe = ++let output_clauses ?(global_constraints = []) ?(enc = Cnf) ~task_pool universe = + let global_constraints = + List.map + (fun (vpkg, l) -> (vpkg, List.map (CudfAdd.pkgtoint universe) l)) + global_constraints + in + let solver = +- Depsolver_int.init_solver_univ ~global_constraints ~buffer:true universe ++ Depsolver_int.init_solver_univ ~task_pool ~global_constraints ~buffer:true universe + in + let clauses = Depsolver_int.S.dump solver.Depsolver_int.constraints in + let size = Cudf.universe_size universe in +@@ -480,47 +483,50 @@ + else Unsat None + + let check_request_using ?call_solver ?dummy ?(explain = false) +- (pre, universe, request) = +- match (call_solver, dummy) with +- | (None, None) -> +- let (u, r) = add_dummy universe request dummy_request in +- remove_dummy ~explain pre (r, edos_install u r) +- | (None, Some dummy) -> +- let (u, r) = add_dummy universe request dummy in +- remove_dummy ~explain pre (r, edos_install u r) +- | (Some call_solver, None) -> ( +- try +- let (presol, sol) = call_solver (pre, universe, request) in +- Sat (presol, sol) +- with +- | CudfSolver.Unsat when not explain -> Unsat None +- | CudfSolver.Unsat when explain -> +- let (u, r) = add_dummy universe request dummy_request in +- remove_dummy ~explain pre (r, edos_install u r)) +- | (Some call_solver, Some dummy) -> ( +- let (u, dr) = add_dummy universe request dummy in +- let dr_constr = (dr.Cudf.package, Some (`Eq, dr.Cudf.version)) in +- let r = +- { request with Cudf.install = dr_constr :: request.Cudf.install } +- in +- try +- let (presol, sol) = call_solver (pre, u, r) in +- let is = List.remove_if (Cudf.( =% ) dr) (Cudf.get_packages sol) in +- Sat (presol, Cudf.load_universe is) +- with +- | CudfSolver.Unsat when not explain -> Unsat None +- | CudfSolver.Unsat when explain -> ( +- let (u, r) = add_dummy universe request dummy in +- match remove_dummy ~explain pre (r, edos_install u r) with +- | Sat _ as sol -> +- warning "External and Internal Solver do not agree." ; +- sol +- | sol -> sol) +- | CudfSolver.Error s -> Error s) ++ ~task_pool (pre, universe, request) = ++ let res = ++ match (call_solver, dummy) with ++ | (None, None) -> ++ let (u, r) = add_dummy universe request dummy_request in ++ remove_dummy ~explain pre (r, edos_install ~task_pool u r) ++ | (None, Some dummy) -> ++ let (u, r) = add_dummy universe request dummy in ++ remove_dummy ~explain pre (r, edos_install ~task_pool u r) ++ | (Some call_solver, None) -> ( ++ try ++ let (presol, sol) = call_solver (pre, universe, request) in ++ Sat (presol, sol) ++ with ++ | CudfSolver.Unsat when not explain -> Unsat None ++ | CudfSolver.Unsat when explain -> ++ let (u, r) = add_dummy universe request dummy_request in ++ remove_dummy ~explain pre (r, edos_install ~task_pool u r)) ++ | (Some call_solver, Some dummy) -> ( ++ let (u, dr) = add_dummy universe request dummy in ++ let dr_constr = (dr.Cudf.package, Some (`Eq, dr.Cudf.version)) in ++ let r = ++ { request with Cudf.install = dr_constr :: request.Cudf.install } ++ in ++ try ++ let (presol, sol) = call_solver (pre, u, r) in ++ let is = List.remove_if (Cudf.( =% ) dr) (Cudf.get_packages sol) in ++ Sat (presol, Cudf.load_universe is) ++ with ++ | CudfSolver.Unsat when not explain -> Unsat None ++ | CudfSolver.Unsat when explain -> ( ++ let (u, r) = add_dummy universe request dummy in ++ match remove_dummy ~explain pre (r, edos_install ~task_pool u r) with ++ | Sat _ as sol -> ++ warning "External and Internal Solver do not agree." ; ++ sol ++ | sol -> sol) ++ | CudfSolver.Error s -> Error s) ++ in ++ res + + (** check if a cudf request is satisfiable. we do not care about + universe consistency . We try to install a dummy package *) +-let check_request ?cmd ?criteria ?dummy ?explain cudf = ++let check_request ?cmd ?criteria ?dummy ?explain ~task_pool cudf = + let call_solver = + match cmd with + | Some cmd -> +@@ -528,7 +534,7 @@ + Some (CudfSolver.execsolver cmd criteria) + | None -> None + in +- check_request_using ?call_solver ?dummy ?explain cudf ++ check_request_using ?call_solver ?dummy ?explain ~task_pool cudf + + type depclean_result = + Cudf.package +@@ -537,20 +543,20 @@ + + (** Depclean. Detect useless dependencies and/or conflicts + to missing or broken packages *) +-let depclean ?(global_constraints = []) ?(callback = fun _ -> ()) universe ++let depclean ?(global_constraints = []) ?(callback = fun _ -> ()) ~task_pool universe + pkglist = + let global_constraints = + List.map + (fun (vpkg, l) -> (vpkg, List.map (CudfAdd.pkgtoint universe) l)) + global_constraints + in +- let cudfpool = Depsolver_int.init_pool_univ ~global_constraints universe in ++ let cudfpool = Depsolver_int.init_pool_univ ~task_pool ~global_constraints universe in + let is_broken = + let cache = Hashtbl.create (Cudf.universe_size universe) in + fun pkg -> + try Hashtbl.find cache pkg + with Not_found -> +- let r = edos_install_cache universe cudfpool [pkg] in ++ let r = edos_install_cache ~task_pool universe cudfpool [pkg] in + let res = not (Diagnostic.is_solution r) in + Hashtbl.add cache pkg res ; + res +@@ -611,7 +617,7 @@ + depends + in + let _ = pool.(pkgid) <- (dll, pkgconf) in +- let res = edos_install_cache univ cudfpool [pkg] in ++ let res = edos_install_cache ~task_pool univ cudfpool [pkg] in + let _ = pool.(pkgid) <- (pkgdeps, pkgconf) in + if not (Diagnostic.is_solution res) then (vpkglist, vpkg, l) :: acc + else acc) +diff -ru dose3.old/src/algo/depsolver.mli dose3/src/algo/depsolver.mli +--- dose3.old/src/algo/depsolver.mli 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/algo/depsolver.mli 2024-03-05 17:56:56.825968960 -0800 +@@ -18,6 +18,7 @@ + (** initialize the solver. *) + val load : + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + solver + +@@ -30,6 +31,7 @@ + Packages marked as `Keep_package must be always installed.*) + val edos_install : + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + Cudf.package -> + Diagnostic.diagnosis +@@ -37,6 +39,7 @@ + (** check if the give package list can be installed in the universe *) + val edos_coinstall : + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + Cudf.package list -> + Diagnostic.diagnosis +@@ -45,6 +48,7 @@ + the cartesian product. *) + val edos_coinstall_prod : + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + Cudf.package list list -> + Diagnostic.diagnosis list +@@ -104,6 +108,7 @@ + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> + ?callback:(Diagnostic.diagnosis -> unit) -> + ?explain:bool -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + int + +@@ -111,6 +116,7 @@ + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> + ?callback:(Diagnostic.diagnosis -> unit) -> + ?explain:bool -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + int + +@@ -128,6 +134,7 @@ + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> + ?callback:(Diagnostic.diagnosis -> unit) -> + ?explain:bool -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + Cudf.package list -> + int +@@ -144,6 +151,7 @@ + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> + ?maxdepth:int -> + ?conjunctive:bool -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + Cudf.package list -> + Cudf.package list +@@ -166,6 +174,7 @@ + val output_clauses : + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> + ?enc:enc -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + string + +@@ -182,6 +191,7 @@ + val depclean : + ?global_constraints:(Cudf_types.vpkglist * Cudf.package list) list -> + ?callback:(depclean_result -> unit) -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + Cudf.package list -> + depclean_result list +@@ -211,6 +221,7 @@ + ?criteria:string -> + ?dummy:Cudf.package -> + ?explain:bool -> ++ task_pool:Domainslib.Task.pool -> + Cudf.cudf -> + solver_result + +@@ -220,6 +231,7 @@ + ?call_solver:(Cudf.cudf -> Cudf.preamble option * Cudf.universe) -> + ?dummy:Cudf.package -> + ?explain:bool -> ++ task_pool:Domainslib.Task.pool -> + Cudf.cudf -> + solver_result + +diff -ru dose3.old/src/algo/depsolver_int.ml dose3/src/algo/depsolver_int.ml +--- dose3.old/src/algo/depsolver_int.ml 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/algo/depsolver_int.ml 2024-03-09 16:52:48.574662646 -0800 +@@ -10,6 +10,7 @@ + (* library, see the COPYING file for more information. *) + (**************************************************************************************) + ++open Domainslib + open ExtLib + open Dose_common + +@@ -48,18 +49,18 @@ + + (* cudf uid -> cudf uid array . Here we assume cudf uid are sequential + and we can use them as an array index *) +-let init_pool_univ ~global_constraints univ = ++let init_pool_univ ~task_pool ~global_constraints univ = + (* the last element of the array *) + let size = Cudf.universe_size univ in + let keep = Hashtbl.create 200 in +- let pool = ++ let pool = Array.make (size + 1) ([], []) in (* Create an array of the desired size *) ++ Task.parallel_for task_pool ~start:0 ~finish:size ~body:(fun uid -> + (* here I initalize the pool to size + 1, that is I reserve one spot + * to encode the global constraints associated with the universe. + * However, since they are global, I've to add the at the end, after + * I have analyzed all packages in the universe. *) +- Array.init (size + 1) (fun uid -> + try +- if uid = size then ([], []) (* the last index *) ++ if uid = size then Array.unsafe_set pool uid ([], []) (* the last index *) + else + let pkg = Cudf.package_by_uid univ uid in + let dll = +@@ -108,13 +109,12 @@ + id) + (CudfAdd.resolve_vpkg_int univ (name, Some (`Eq, v)))) + pkg.Cudf.provides) ; +- (dll, cl) ++ Array.unsafe_set pool uid (dll, cl) + with Not_found -> + fatal + "Package uid (%d) not found during solver pool initialization. \ + Packages uid must have no gaps in the given universe" +- uid) +- in ++ uid); + let keep_dll = + Hashtbl.fold + (fun cnstr { contents = l } acc -> ([cnstr], l) :: acc) +@@ -161,7 +161,7 @@ + `SolverPool solverpool + + (** initalise the sat solver. operate only on solver ids *) +-let init_solver_cache ?(buffer = false) ?(explain = true) (`SolverPool varpool) ++let init_solver_cache ?(buffer = false) ?(explain = true) ~task_pool (`SolverPool varpool) + = + let num_conflicts = ref 0 in + let num_disjunctions = ref 0 in +@@ -170,7 +170,7 @@ + let varsize = Array.length varpool in + let add_depend constraints vpkgs pkg_id l = + let lit = S.lit_of_var pkg_id false in +- if List.length l = 0 then ++ if (match l with [] -> true | _ -> false) then + S.add_rule + constraints + [| lit |] +@@ -308,16 +308,17 @@ + @param buffer debug buffer to print out debug messages + @param univ cudf package universe + *) +-let init_solver_univ ~global_constraints ?(buffer = false) ?(explain = true) ++let init_solver_univ ~task_pool ~global_constraints ?(buffer = false) ?(explain = true) ++ + univ = + let map = new Util.identity in + (* here we convert a cudfpool in a varpool. The assumption + * that cudf package identifiers are contiguous is essential ! *) + let (`CudfPool (keep_constraints, pool)) = +- init_pool_univ ~global_constraints univ ++ init_pool_univ ~task_pool ~global_constraints univ + in + let varpool = `SolverPool pool in +- let constraints = init_solver_cache ~buffer ~explain varpool in ++ let constraints = init_solver_cache ~buffer ~explain ~task_pool varpool in + let gid = Cudf.universe_size univ in + let global_constraints = global_constraints <> [] in + { constraints; map; globalid = ((keep_constraints, global_constraints), gid) } +@@ -330,7 +331,7 @@ + @param pool dependencies and conflicts array idexed by package id + @param closure subset of packages used to initialize the solver + *) +-let init_solver_closure ~global_constraints ?(buffer = false) ++let init_solver_closure ~task_pool ~global_constraints ?(buffer = false) + (`CudfPool (keep_constraints, cudfpool)) closure = + let gid = Array.length cudfpool - 1 in + let global_constraints = global_constraints <> [] in +@@ -339,7 +340,7 @@ + let varpool = + init_solver_pool map (`CudfPool (keep_constraints, cudfpool)) closure + in +- let constraints = init_solver_cache ~buffer varpool in ++ let constraints = init_solver_cache ~task_pool ~buffer varpool in + { constraints; map; globalid = ((keep_constraints, global_constraints), gid) } + + (** return a copy of the state of the solver *) +diff -ru dose3.old/src/algo/depsolver_int.mli dose3/src/algo/depsolver_int.mli +--- dose3.old/src/algo/depsolver_int.mli 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/algo/depsolver_int.mli 2024-03-04 15:02:41.957045110 -0800 +@@ -79,6 +79,7 @@ + The last index of the pool is the globalid. + *) + val init_pool_univ : ++ task_pool:Domainslib.Task.pool -> + global_constraints:global_constraints -> + Cudf.universe -> + [> `CudfPool of bool * pool ] +@@ -93,7 +94,7 @@ + + (** Initalise the sat solver. Operates only on solver ids [SolverPool] *) + val init_solver_cache : +- ?buffer:bool -> ?explain:bool -> [< `SolverPool of pool ] -> S.state ++ ?buffer:bool -> ?explain:bool -> task_pool:Domainslib.Task.pool -> [< `SolverPool of pool ] -> S.state + + (** Call the sat solver + +@@ -125,6 +126,7 @@ + @param univ cudf package universe + *) + val init_solver_univ : ++ task_pool:Domainslib.Task.pool -> + global_constraints:global_constraints -> + ?buffer:bool -> + ?explain:bool -> +@@ -140,6 +142,7 @@ + @param closure subset of packages used to initialize the solver + *) + val init_solver_closure : ++ task_pool:Domainslib.Task.pool -> + global_constraints:global_constraints -> + ?buffer:bool -> + [< `CudfPool of bool * pool ] -> +diff -ru dose3.old/src/algo/dune dose3/src/algo/dune +--- dose3.old/src/algo/dune 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/algo/dune 2024-03-10 15:01:14.855440042 -0700 +@@ -1,7 +1,7 @@ + (library + (name dose_algo) + (public_name dose3.algo) +- (libraries extlib cudf dose3.common ocamlgraph) ++ (libraries extlib cudf dose3.common ocamlgraph domainslib) + (flags (:standard))) + + (rule +diff -ru dose3.old/src/algo/strongconflicts.ml dose3/src/algo/strongconflicts.ml +--- dose3.old/src/algo/strongconflicts.ml 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/algo/strongconflicts.ml 2024-03-10 15:04:35.975438279 -0700 +@@ -54,10 +54,10 @@ + Depsolver.trim. + *) + +-let strongconflicts universe = ++let strongconflicts ~task_pool universe = + let g = CG.create () in + let universe = Depsolver.trim universe in +- let ig = Strongconflicts_int.strongconflicts universe in ++ let ig = Strongconflicts_int.strongconflicts ~task_pool universe in + let inttovar = CudfAdd.inttopkg universe in + (* convert output graph *) + ICG.iter_vertex (fun v -> CG.add_vertex g (inttovar v)) ig ; +diff -ru dose3.old/src/algo/strongconflicts_int.ml dose3/src/algo/strongconflicts_int.ml +--- dose3.old/src/algo/strongconflicts_int.ml 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/algo/strongconflicts_int.ml 2024-03-10 15:02:47.625439229 -0700 +@@ -13,6 +13,7 @@ + (** Strong Conflicts *) + + open ExtLib ++open Domainslib + open Dose_common + + include Util.Logging (struct +@@ -80,8 +81,8 @@ + else false + + (* [strongconflicts mdf] return the list of strong conflicts *) +-let strongconflicts univ = +- let solver = Depsolver_int.init_solver_univ ~global_constraints:[] univ in ++let strongconflicts ~task_pool univ = ++ let solver = Depsolver_int.init_solver_univ ~task_pool ~global_constraints:[] univ in + let reverse = Depsolver_int.reverse_dependencies univ in + let size = Cudf.universe_size univ in + let cache = IG.make size in +diff -ru dose3.old/src/algo/strongdeps.ml dose3/src/algo/strongdeps.ml +--- dose3.old/src/algo/strongdeps.ml 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/algo/strongdeps.ml 2024-03-09 12:14:36.924808973 -0800 +@@ -13,6 +13,7 @@ + (** Strong Dependencies *) + + open ExtLib ++open Domainslib + open Dose_common + + include Util.Logging (struct +@@ -74,9 +75,9 @@ + *) + + (** [strongdeps l] build the strong dependency graph of l *) +-let strongdeps_int ?(transitive = true) graph univ pkglist = ++let strongdeps_int ?(transitive = true) ~task_pool graph univ pkglist = + let global_constraints = [] in +- let cudfpool = Depsolver_int.init_pool_univ ~global_constraints univ in ++ let cudfpool = Depsolver_int.init_pool_univ ~task_pool ~global_constraints univ in + let pkglist_size = List.length pkglist in + let universe_size = Cudf.universe_size univ in + Util.Progress.set_total mainbar pkglist_size ; +@@ -89,7 +90,7 @@ + if pkglist_size <> universe_size || somedisj cudfpool id then + let closure = Depsolver_int.dependency_closure_cache cudfpool [id] in + let solver = +- Depsolver_int.init_solver_closure ~global_constraints cudfpool closure ++ Depsolver_int.init_solver_closure ~global_constraints ~task_pool cudfpool closure + in + match Depsolver_int.solve solver ~explain:true [id] with + | Diagnostic.FailureInt _ -> () +@@ -103,12 +104,13 @@ + (Defaultgraphs.PackageGraph.G.nb_edges graph) ; + Util.Timer.stop strongtimer graph + +-let strongdeps ?(transitive = true) univ pkglist = ++let strongdeps ?(transitive = true) ~task_pool univ pkglist = + let size = Cudf.universe_size univ in + let graph = Defaultgraphs.PackageGraph.G.create ~size () in +- strongdeps_int ~transitive graph univ pkglist ++ let res = strongdeps_int ~transitive ~task_pool graph univ pkglist in ++ res + +-let strongdeps_univ ?(transitive = true) univ = ++let strongdeps_univ ?(transitive = true) ~task_pool univ = + let size = Cudf.universe_size univ in + let graph = Defaultgraphs.PackageGraph.G.create ~size () in + Util.Progress.set_total conjbar size ; +@@ -128,7 +130,7 @@ + "conj dep graph: nodes %d , edges %d" + (Defaultgraphs.PackageGraph.G.nb_vertex graph) + (Defaultgraphs.PackageGraph.G.nb_edges graph) ; +- let g = strongdeps_int ~transitive graph univ l in ++ let g = strongdeps_int ~transitive ~task_pool graph univ l in + (* because the graph might still be transitive *) + (* if not transitive then O.transitive_reduction g; *) + g +@@ -149,13 +151,13 @@ + + (** [strongdeps u l] build the strong dependency graph of all packages in + l wrt the universe u *) +-let strongdeps ?(transitive = true) universe pkglist = +- strongdeps ~transitive universe (Depsolver.trimlist universe pkglist) ++let strongdeps ?(transitive = true) ~task_pool universe pkglist = ++ strongdeps ~transitive ~task_pool universe (Depsolver.trimlist universe pkglist) + + (** [strongdeps_univ u] build the strong dependency graph of + all packages in the universe [u] *) +-let strongdeps_univ ?(transitive = true) universe = +- strongdeps_univ ~transitive (Depsolver.trim universe) ++let strongdeps_univ ?(transitive = true) ~task_pool universe = ++ strongdeps_univ ~transitive ~task_pool (Depsolver.trim universe) + + (** compute the impact set of the node [q], that is the list of all + packages [p] that strong depends on [q] *) +diff -ru dose3.old/src/algo/strongdeps.mli dose3/src/algo/strongdeps.mli +--- dose3.old/src/algo/strongdeps.mli 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/algo/strongdeps.mli 2024-03-09 12:13:44.684809431 -0800 +@@ -12,20 +12,24 @@ + + (** Strong Dependencies *) + +-(** [strongdeps u l] build the strong dependency graph of all packages in ++(** [strongdeps u l] build the strong dependency graph of all packages in + [l] wrt the universe [u] *) + val strongdeps : + ?transitive:bool -> ++ task_pool:Domainslib.Task.pool -> + Cudf.universe -> + Cudf.package list -> + Defaultgraphs.PackageGraph.G.t + +-(** [strongdeps_univ u] build the strong dependency graph of ++(** [strongdeps_univ u] build the strong dependency graph of + all packages in the universe [u] *) + val strongdeps_univ : +- ?transitive:bool -> Cudf.universe -> Defaultgraphs.PackageGraph.G.t ++ ?transitive:bool -> ++ task_pool:Domainslib.Task.pool -> ++ Cudf.universe -> ++ Defaultgraphs.PackageGraph.G.t + +-(** compute the impact set of the node [q], that is the list of all ++(** compute the impact set of the node [q], that is the list of all + packages [p] that strong depends on [q] *) + val impactset : + Defaultgraphs.PackageGraph.G.t -> Cudf.package -> Cudf.package list +@@ -33,7 +37,7 @@ + (** compute the conjunctive dependency graph *) + val conjdeps_univ : Cudf.universe -> Defaultgraphs.PackageGraph.G.t + +-(** compute the conjunctive dependency graph considering only packages ++(** compute the conjunctive dependency graph considering only packages + in [pkglist] *) + val conjdeps : + Cudf.universe -> Cudf.package list -> Defaultgraphs.PackageGraph.G.t +diff -ru dose3.old/src/common/cudfSolver.ml dose3/src/common/cudfSolver.ml +--- dose3.old/src/common/cudfSolver.ml 2021-07-22 00:14:19.000000000 -0700 ++++ dose3/src/common/cudfSolver.ml 2024-03-10 15:13:34.915433554 -0700 +@@ -37,12 +37,25 @@ + false + + let prng = lazy (Random.State.make_self_init ()) ++let prng_mutex = Mutex.create () + + (* bits and pieces borrowed from ocaml stdlib/filename.ml *) + let mktmpdir prefix suffix = + let temp_dir = try Sys.getenv "TMPDIR" with Not_found -> "/tmp" in + let temp_file_name temp_dir prefix suffix = +- let rnd = Random.State.bits (Lazy.force prng) land 0xFFFFFF in ++ let rnd = ++ let prng = ++ Mutex.lock prng_mutex; ++ try ++ let res = Lazy.force prng in ++ Mutex.unlock prng_mutex; ++ res ++ with e -> ++ Mutex.unlock prng_mutex; ++ raise e ++ in ++ Random.State.bits prng land 0xFFFFFF ++ in + Filename.concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix) + in + let rec try_name counter =