From 20dc45767037ba70be7f7bde45138ca20838195d Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Sat, 23 Nov 2024 10:24:53 +0100 Subject: [PATCH] feat: solver refactoring (#1739) * Priority-based solver * Compiler priorities * Fine tweaks related to pins & conflicts * Self-review * Fix feasibility check not considering pins * Optimization: filter out seen linked deps * Fix issue with search timeout * Self-review * Fix submodules after rebase * Remove dependency on compare_to_case --- .github/workflows/ci-toolchain.yml | 7 +- .gitmodules | 2 +- TODO | 1 + alire.toml | 2 +- alr_env.gpr | 1 + src/alire/alire-conditional_trees.ads | 1 - src/alire/alire-meta.ads | 4 +- src/alire/alire-releases-containers.ads | 3 + src/alire/alire-solutions.adb | 128 +- src/alire/alire-solutions.ads | 32 +- src/alire/alire-solver-predefined_options.ads | 40 +- src/alire/alire-solver.adb | 2141 ++++++++++------- src/alire/alire-solver.ads | 153 +- src/alire/alire-utils-comparisons.ads | 50 + src/alire/alire.ads | 4 + src/alr/alr-commands-search.adb | 6 +- .../tests/solver/compiler-selected/test.py | 5 + testsuite/tests/solver/forbids/test.py | 4 +- 18 files changed, 1639 insertions(+), 945 deletions(-) create mode 100644 TODO create mode 100644 src/alire/alire-utils-comparisons.ads diff --git a/.github/workflows/ci-toolchain.yml b/.github/workflows/ci-toolchain.yml index 95a19ef26..a40f3aa44 100644 --- a/.github/workflows/ci-toolchain.yml +++ b/.github/workflows/ci-toolchain.yml @@ -102,7 +102,8 @@ jobs: run: ./bin/alr -d -n version | grep 'compiled with version' | grep -q '${{ matrix.gcc_version }}' - name: Update dependencies - run: ./bin/alr -d -n update + run: ./bin/alr -d -n -f update + # Force because otherwise solving may time out in non-interactive mode - name: Show dependencies/pins run: ./bin/alr -d -n -q with --solve || ./bin/alr -n -v -d with --solve @@ -112,7 +113,9 @@ jobs: - name: Move ./bin to ./bin-old to allow for self-build shell: bash - run: mv ./bin ./bin-old || { sleep 5s && mv ./bin ./bin-old; } + run: | + mv ./bin ./bin-old || \ + { sleep 5s && mv ./bin ./bin-old && echo Old moved on 2nd attempt; } # Windows doesn't allow to replace a running exe so the next command # fails otherwise. Also, this mv fails sometimes so we try twice JIC. diff --git a/.gitmodules b/.gitmodules index a75b444a3..f150d0ee9 100644 --- a/.gitmodules +++ b/.gitmodules @@ -65,4 +65,4 @@ url = https://github.com/mosteo/cstrings [submodule "deps/lml"] path = deps/lml - url = https://github.com/mosteo/lml_ada.git + url = https://github.com/mosteo/lml_ada diff --git a/TODO b/TODO new file mode 100644 index 000000000..4c336d1fa --- /dev/null +++ b/TODO @@ -0,0 +1 @@ +- Test of solver timeout behaviors diff --git a/alire.toml b/alire.toml index 4659a68cf..66e590be1 100644 --- a/alire.toml +++ b/alire.toml @@ -51,7 +51,6 @@ windows = { ALIRE_OS = "windows" } # Some dependencies require precise versions during the development cycle: [[pins]] - [pins.aaa] url = "https://github.com/mosteo/aaa" commit = "ddfeffe2d6c8f9d19161df7b31d16d37bef4ba71" @@ -127,3 +126,4 @@ command = ["pwsh", "scripts/version-patcher.ps1"] [actions.'case(os)'.'...'] type = "pre-build" command = ["scripts/version-patcher.sh"] + diff --git a/alr_env.gpr b/alr_env.gpr index c9a6a6b3e..5b14702b4 100644 --- a/alr_env.gpr +++ b/alr_env.gpr @@ -14,6 +14,7 @@ aggregate project Alr_Env is "deps/ajunitgen", "deps/ansi", "deps/clic", + "deps/compare_to_case", "deps/cstrings", "deps/den", "deps/dirty_booleans", diff --git a/src/alire/alire-conditional_trees.ads b/src/alire/alire-conditional_trees.ads index 0fdfe0d0b..1f5219c14 100644 --- a/src/alire/alire-conditional_trees.ads +++ b/src/alire/alire-conditional_trees.ads @@ -90,7 +90,6 @@ package Alire.Conditional_Trees with Preelaborate is with Post'Class => Flatten'Result.Is_Empty or else Flatten'Result.Is_Value or else Flatten'Result.Is_Vector; - -- Above Post kept for reference but gnat bugs out during instantiation. -- Recursively merge all subtree elements in a single value or vector. It -- can result in an empty tree if a vector is empty, so it returns a tree. diff --git a/src/alire/alire-meta.ads b/src/alire/alire-meta.ads index c8d259930..1ae8c5627 100644 --- a/src/alire/alire-meta.ads +++ b/src/alire/alire-meta.ads @@ -6,8 +6,8 @@ package Alire.Meta with Preelaborate is package Working_Tree is - Commit : constant String := "unknown"; - Changes : constant String := "unknown"; + Commit : constant String := "c3dade93403aaacec59097e450a22ce83e0ceb0f"; + Changes : constant String := "dirty"; end Working_Tree; diff --git a/src/alire/alire-releases-containers.ads b/src/alire/alire-releases-containers.ads index 07d841c19..fd9309406 100644 --- a/src/alire/alire-releases-containers.ads +++ b/src/alire/alire-releases-containers.ads @@ -14,6 +14,9 @@ package Alire.Releases.Containers is Release_Image); subtype Optional is Optional_Releases.Optional; + function Unit (Element : Releases.Release) return Optional + renames Optional_Releases.Unit; + package Release_Sets is new Ada.Containers.Indefinite_Ordered_Sets (Releases.Release, Releases."<", diff --git a/src/alire/alire-solutions.adb b/src/alire/alire-solutions.adb index d9609eb46..d34f837bd 100644 --- a/src/alire/alire-solutions.adb +++ b/src/alire/alire-solutions.adb @@ -6,10 +6,8 @@ with Alire.Dependencies.Diffs; with Alire.Dependencies.Graphs; with Alire.Errors; with Alire.Index; -with Alire.Milestones; with Alire.Root; with Alire.Solutions.Diffs; -with Alire.Toolchains; with Alire.Utils.Tables; with Alire.Utils.Tools; with Alire.Utils.TTY; @@ -21,6 +19,7 @@ package body Alire.Solutions is package Semver renames Semantic_Versioning; use type Ada.Containers.Count_Type; + use type Alire.Releases.Release; use type Semantic_Versioning.Version; use all type States.Missed_Reasons; @@ -51,6 +50,26 @@ package body Alire.Solutions is else Mixed); + -------------- + -- Contains -- + -------------- + + function Contains (This : Solution; + Release : Alire.Releases.Release) return Boolean + is (for some Rel of This.Releases => Rel = Release); + + -------------- + -- Contains -- + -------------- + + function Contains (This : Solution; + Release : Milestones.Milestone) return Boolean + is + use type Milestones.Milestone; + begin + return (for some Rel of This.Releases => Rel.Milestone = Release); + end Contains; + ---------------------- -- Contains_Release -- ---------------------- @@ -59,6 +78,16 @@ package body Alire.Solutions is Crate : Crate_Name) return Boolean is (This.Depends_On (Crate) and then This.State (Crate).Has_Release); + --------------------------- + -- Contains_Incompatible -- + --------------------------- + + function Contains_Incompatible (This : Solution; + Release : Alire.Releases.Release) + return Boolean + is (for some Dep of This.Dependencies => + Dep.Has_Release and then Release.Satisfies (Dep)); + ---------------- -- Dependency -- ---------------- @@ -92,6 +121,14 @@ package body Alire.Solutions is return Result; end Excluding; + ------------------------- + -- Depends_Directly_On -- + ------------------------- + + function Depends_Directly_On (This : Solution; + Name : Crate_Name) return Boolean + is (This.Dependencies.Contains (Name)); + ---------------- -- Depends_On -- ---------------- @@ -111,15 +148,6 @@ package body Alire.Solutions is Release : Alire.Releases.Release) return Boolean is (for some Dep of This.Dependencies => Release.Provides (Dep.Crate)); - ------------------------------ - -- Depends_On_Specific_GNAT -- - ------------------------------ - - function Depends_On_Specific_GNAT (This : Solution) return Boolean - is (This.Releases.Contains_Or_Provides (GNAT_Crate) and then - (for some Rel of This.Releases.Elements_Providing (GNAT_Crate) => - Rel.Name /= GNAT_Crate)); - ---------------------------- -- Empty_Invalid_Solution -- ---------------------------- @@ -241,6 +269,17 @@ package body Alire.Solutions is return Boolean is (for some Solved of This.Releases => Solved.Provides (Release)); + --------------- + -- Satisfies -- + --------------- + + function Satisfies (This : Solution; + Dep : Dependencies.Dependency'Class) + return Boolean + is (This.Links.Contains (Dep.Crate) + or else + (for some Solved of This.Releases => Solved.Satisfies (Dep))); + --------------- -- Resetting -- --------------- @@ -409,18 +448,48 @@ package body Alire.Solutions is Env : Properties.Vector) return Boolean is + use type Milestones.Milestone; begin return - -- Some of the releases in the solution forbid this one release - ((for some Solved of This.Releases => - (for some Dep of Solved.Forbidden (Env) => - Release.Satisfies (Dep.Value))) - or else - -- The candidate release forbids something in the solution - (for some Dep of Release.Forbidden (Env) => - (for some Rel of This.Releases => Rel.Satisfies (Dep.Value)))); + -- Some of the releases in the solution forbid this one release + (for all Solved of This.Releases => + Solved.Milestone /= Release.Milestone) + and then + ((for some Solved of This.Releases => + (for some Dep of Solved.Forbidden (Env) => + Release.Satisfies (Dep.Value))) + or else + -- The candidate release forbids something in the solution + (for some Dep of Release.Forbidden (Env) => + (for some Rel of This.Releases => Rel.Satisfies (Dep.Value)))); end Forbids; + -------------------- + -- Image_One_Line -- + -------------------- + + function Image_One_Line (This : Solution) return String is + use UStrings; + Result : UString; + First : Boolean := True; + begin + for State of This.Dependencies loop + if First then + First := False; + else + Result := Result & "; "; + end if; + + if State.Has_Release then + Append (Result, State.Release.Milestone.TTY_Image); + else + Append (Result, State.TTY_Image); + end if; + end loop; + + return +Result; + end Image_One_Line; + --------------- -- Including -- --------------- @@ -508,27 +577,6 @@ package body Alire.Solutions is -- TODO: instead of using the first discrepancy, we should count all -- differences and see which one is globally "newer". - -- Prefer one with an installed compiler - - for Rel_L of This.Releases loop - if Rel_L.Provides (GNAT_Crate) then - for Rel_R of Than.Releases loop - if Rel_R.Provides (GNAT_Crate) then - if Toolchains.Available.Contains (Rel_L) - xor Toolchains.Available.Contains (Rel_R) - then - return (if Toolchains.Available.Contains (Rel_L) - then Better - else Worse); - else - exit; -- No need to keep checking, 1 compiler in sol - end if; - end if; - end loop; - exit; -- No need to keep checking, only 1 compiler in sol - end if; - end loop; - -- Check releases in both only for Rel of This.Releases loop diff --git a/src/alire/alire-solutions.ads b/src/alire/alire-solutions.ads index 42e4e1efe..b56cb7660 100644 --- a/src/alire/alire-solutions.ads +++ b/src/alire/alire-solutions.ads @@ -3,6 +3,7 @@ with Alire.Containers; with Alire.Dependencies.Containers; with Alire.Dependencies.States.Maps; with Alire.Interfaces; +with Alire.Milestones; with Alire.Optional; with Alire.Properties; with Alire.Releases.Containers; @@ -186,11 +187,25 @@ package Alire.Solutions is function Composition (This : Solution) return Compositions; + function Contains (This : Solution; + Release : Alire.Releases.Release) return Boolean; + -- Say if the solution contains exactly this release + + function Contains (This : Solution; + Release : Milestones.Milestone) return Boolean; + function Contains_Release (This : Solution; Crate : Crate_Name) return Boolean; -- Say if Crate is among the releases (solved or linked) for this solution. -- It will return False if the solution does not even depend on Crate. + function Contains_Incompatible (This : Solution; + Release : Alire.Releases.Release) + return Boolean; + -- Say if this solution already contains a release for a dependency + -- provided by the given release; in which case Release cannot be added + -- to this solution for a different dependency. + function Crates (This : Solution) return Name_Set; -- Dependency name closure, independent of the status in the solution, as -- found by the solver starting from the direct dependencies. @@ -221,6 +236,10 @@ package Alire.Solutions is -- This function allows identifying the concrete dependency that a solved -- release introduced in the solution. + function Depends_Directly_On (This : Solution; + Name : Crate_Name) return Boolean; + -- Says if Name is one of the dependency state keys in solution + function Depends_On (This : Solution; Name : Crate_Name) return Boolean; -- Says if the solution depends on the crate in some way. Will also @@ -230,9 +249,6 @@ package Alire.Solutions is Release : Alire.Releases.Release) return Boolean; -- Likewise, but take also into account the Release.Provides - function Depends_On_Specific_GNAT (This : Solution) return Boolean; - -- Say if the solution contains a release which is a gnat_something - function Forbidden (This : Solution; Env : Properties.Vector) return Dependency_Map; @@ -250,6 +266,12 @@ package Alire.Solutions is -- Check whether the solution already contains or provides a release -- equivalent to Release. + function Satisfies (This : Solution; + Dep : Dependencies.Dependency'Class) + return Boolean; + -- Say if some release already in solution will satisfy Dep, either + -- directly, via provides, or via link. + function Dependencies_Providing (This : Solution; Crate : Crate_Name) return State_Map; @@ -346,6 +368,10 @@ package Alire.Solutions is -- I/O -- --------- + function Image_One_Line (This : Solution) return String; + -- Simplified representation containing only solved milestones or unsolved + -- dependencies + procedure Print (This : Solution; Root : Alire.Releases.Release; Env : Properties.Vector; diff --git a/src/alire/alire-solver-predefined_options.ads b/src/alire/alire-solver-predefined_options.ads index 30f6687a0..338f57678 100644 --- a/src/alire/alire-solver-predefined_options.ads +++ b/src/alire/alire-solver-predefined_options.ads @@ -2,35 +2,19 @@ package Alire.Solver.Predefined_Options is Default_Options : Query_Options renames Solver.Default_Options; - Default_Options_Not_Interactive : constant Query_Options := - (On_Timeout => Stop, - others => <>); + Best_Effort : constant Query_Options := + (Stopping => Stop, + others => <>); + -- Look until first timeout - Complete_Only : constant Query_Options := - (Exhaustive => False, -- only attempt complete ones - On_Timeout => Continue, - others => <>); - -- Only return a complete solution, but try for as long as it takes + Interactive : constant Query_Options := + (Stopping => Ask, + others => <>); + -- Ask of timeout - Complete_Or_Good_Incomplete : constant Query_Options - := (On_Timeout => Continue_While_Complete_Then_Stop, - others => <>); - -- Intended to find a complete solution, or else return an incomplete one - -- that helps with diagnosing the trouble. This one looks for incompletes - -- during one timeout period after all complete have been explored without - -- timeout. - - Exhaustive_Options : constant Query_Options := - (Completeness => All_Incomplete, - others => <>); - -- Explore the full solution space - - Find_Best_Options : constant Query_Options := - (Completeness => All_Complete, - others => <>); - -- Find all complete solutions and return the "best" one (see - -- Solutions.Is_Better). It does not yet make sense to use this setting - -- because with the current Is_Better implementation, the first complete - -- solution found is the one considered best anyway. + Exhaustive : constant Query_Options := + (Stopping => Continue, + others => <>); + -- Try as long as it takes to find a complete solution end Alire.Solver.Predefined_Options; diff --git a/src/alire/alire-solver.adb b/src/alire/alire-solver.adb index 59b732708..d4f86cc9e 100644 --- a/src/alire/alire-solver.adb +++ b/src/alire/alire-solver.adb @@ -1,30 +1,24 @@ with Ada.Containers; use Ada.Containers; with Ada.Containers.Indefinite_Ordered_Sets; -with Alire.Conditional; with Alire.Containers; -with Alire.Dependencies.Containers; with Alire.Dependencies.States; -with Alire.Errors; with Alire.Milestones; with Alire.Optional; with Alire.Platforms.Current; with Alire.Releases.Containers; with Alire.Root; with Alire.Toolchains; +with Alire.Utils.Comparisons; with Alire.Utils.TTY; with CLIC.User_Input; with Stopwatch; -package body Alire.Solver is - - Solution_Found : exception; - -- Used to prematurely end search when a complete solution exists +with System.Pool_Local; - Solution_Timeout : exception; - -- Used on search timeout; solution might not even exist or be incomplete +package body Alire.Solver is package Semver renames Semantic_Versioning; @@ -32,15 +26,6 @@ package body Alire.Solver is use all type Dependencies.States.Missed_Reasons; use all type Dependencies.States.Transitivities; - package Solution_Sets is new Ada.Containers.Indefinite_Ordered_Sets - (Element_Type => Solution, - "<" => Solutions.Is_Better, - "=" => Solutions."="); - - type State_Id is mod 2**32 - 1; - - Current_Id : State_Id := 0; - ------------- -- Next_Id -- ------------- @@ -52,79 +37,136 @@ package body Alire.Solver is end return; end Next_Id; - type Search_State is record - Id : State_Id := Next_Id; + ----------------- + -- Downgrading -- + ----------------- + + function Downgrading (This : access Search_State; + Downgrades : Natural) + return access Search_State + is + begin + This.Downgrade := This.Downgrade + Downgrades; + return This; + end Downgrading; + + ------------ + -- Seeing -- + ------------ + + function Seeing (This : access Search_State; + Deps : Dependencies.Dependency) + return access Search_State + is + begin + This.Seen.Union (Dependencies.Containers.To_Set (Deps)); + return This; + end Seeing; + + --------------- + -- Expanding -- + --------------- + + function Expanding (This : access Search_State; + Rel : Releases.Release) + return access Search_State + is + begin + This.Expanded.Append (Rel.To_Dependency); + return This; + end Expanding; - Parent : State_Id := 0; + --------------- + -- Expanding -- + --------------- - Seen : Dependencies.Containers.Set; - -- Any dependency already seen needs not to be explored, as it has been - -- done at some point upwards the search tree. + function Expanding (This : access Search_State; + Rel : Conditional.Dependencies) + return access Search_State + is + begin + This.Expanded.Append (Rel); + return This; + end Expanding; - Expanded, - -- Nodes already processed + --------------- + -- Targeting -- + --------------- - Target, - -- Next subtree to consider + function Targeting (This : access Search_State; + Dep : Conditional.Dependencies) + return access Search_State + is + begin + This.Target := Dep; + return This; + end Targeting; - Remaining : Types.Platform_Dependencies; - -- Nodes pending to be considered + --------------- + -- With_More -- + --------------- - Solution : Alire.Solutions.Solution; - -- Partial or complete solution that stores releases - -- and dependencies processed up to now - end record; + function With_More (This : access Search_State; + Deps : Conditional.Dependencies) + return access Search_State + is + begin + This.Remaining := Deps; + return This; + end With_More; - -------------------- - -- Image_One_Line -- - -------------------- + ------------ + -- Solved -- + ------------ - function Image_One_Line (State : Search_State) return String + function Solved (This : access Search_State; + As : Solutions.Solution) + return access Search_State is - use Conditional.For_Dependencies; begin - if Trace.Level = Debug then - return "" - & "i:" & State.Id'Image & "; p:" & State.Parent'Image & "; " - & "TARGET: " & State.Target.Image_One_Line & "; " - & "SEEN: " & State.Seen.Image_One_Line & "; " - & "EXPANDED: " & State.Expanded.Image_One_Line & "; " - & "REMAIN: " & State.Remaining.Image_One_Line & "; " - ; - else - return ""; - end if; - end Image_One_Line; + This.Solution := As; + return This; + end Solved; ----------------- - -- Print_Debug -- + -- To_Solution -- ----------------- - procedure Print_Debug (State : Search_State; - Level : Trace.Levels := Trace.Debug) - is + function To_Solution (This : Search_State) return Solution is + use type Conditional.Dependencies; + Full : Solutions.Solution := This.Solution; begin - if Level <= Trace.Level then - Trace.Log (" i:" & State.Id'Image - & "; p:" & State.Parent'Image, Level); - Trace.Log (" TARGET: " & State.Target.Image_One_Line, Level); - Trace.Log (" SEEN: " & State.Seen.Image_One_Line, Level); - Trace.Log (" EXPANDED: " & State.Expanded.Image_One_Line, Level); - Trace.Log (" REMAIN: " & State.Remaining.Image_One_Line, Level); - Trace.Log (" SOLUTION: " - & State.Solution.All_Dependencies.Image_One_Line, Level); - end if; - end Print_Debug; + -- Convert all non-visited dependencies into missed, or else just the + -- state's solution + + -- Any pending dependencies should be considered missing, since they + -- can potentially conflict with a release in the solution. Even if + -- they were compatible, they might require unexplored dependencies that + -- would be missing. So the safe route is to mark them all missing. + + for Dep of Conditional.Enumerate (This.Target and This.Remaining) loop + Full := Full.Missing (Dep, Skipped); + end loop; + + return Full; + end To_Solution; + + ------------------- + -- Pending_Count -- + ------------------- + + function Pending_Count (This : Search_State) return Natural + is (This.Target.Leaf_Count + This.Remaining.Leaf_Count); ----------- -- Image -- ----------- function Image (Options : Query_Options) return String - is ("Age order: " & TTY.Emph (Options.Age'Image) - & "; Completeness: " & TTY.Emph (Options.Completeness'Image) - & "; Externals: " & TTY.Emph (Options.Detecting'Image) - & "; Hinting: " & TTY.Emph (Options.Hinting'Image)); + is ("Age order: " & TTY.Emph (Options.Age'Image) + & "; Stopping: " & TTY.Emph (Options.Stopping'Image) + & "; Externals: " & TTY.Emph (Options.Detecting'Image) + & "; Hinting: " & TTY.Emph (Options.Hinting'Image)); ------------ -- Exists -- @@ -181,27 +223,13 @@ package body Alire.Solver is return Boolean is (Resolve (Deps, Props, Pins, Options).Is_Complete); - --------------------- - -- Culprit_Is_Toolchain -- - --------------------- - -- Say if the reason for the solution to be incomplete is that it requires - -- a tool from the toolchain that is not already installed - function Culprit_Is_Toolchain (Sol : Solutions.Solution) return Boolean is - begin - return - (for all Dep of Sol.Hints => - Toolchains.Tools.Contains (Dep.Crate)); - end Culprit_Is_Toolchain; - ------------- -- Resolve -- ------------- function Resolve (Dep : Dependencies.Dependency; - Options : Query_Options := - (On_Timeout => Continue_While_Complete_Then_Stop, - others => <>)) + Options : Query_Options := Default_Options) return Solution is (Resolve (Deps => Conditional.New_Dependency (Dep), Props => Platforms.Current.Properties, @@ -218,21 +246,41 @@ package body Alire.Solver is Options : Query_Options := Default_Options) return Solution is + Tmp_Pool : System.Pool_Local.Unbounded_Reclaim_Pool; + -- We use a local pool for easy reduction of copying of large states, + -- without needing to manage memory. + + type State_Ptr is access all Search_State; + for State_Ptr'Storage_Pool use Tmp_Pool; + + ---------- + -- Next -- + ---------- + + function Next (This : Search_State) return access Search_State + is + Child : constant State_Ptr := new Search_State'(This); + -- Allocated in local pool + begin + Child.Id := Next_Id; + Child.Parent := This.Id; + return Child; + end Next; + Index_Query_Options : constant Index.Query_Options := (Load_From_Disk => True, Detect_Externals => Options.Detecting = Detect); Progress : Trace.Ongoing := Trace.Activity ("Solving dependencies"); - Timer : Stopwatch.Instance := - Stopwatch.With_Elapsed (Options.Elapsed); + Timer : Stopwatch.Instance; -- Total time spent searching Update_Timer : Stopwatch.Instance; -- To avoid reporting progress too often, as this will have some impact -- on time spent searching. - Timeout : Duration := Options.Timeout + Options.Elapsed; + Timeout : Duration := Options.Timeout; use Alire.Conditional.For_Dependencies; @@ -251,23 +299,15 @@ package body Alire.Solver is -- Still, we can keep track of indirect unsolvable deps to speed-up the -- search by not reattempting branches that contain such a dependency. - -- On the solver internal operation: the solver recursively tries all - -- possible dependency combinations, in depth-first order. This means - -- that, for a given dependency, all satisfying releases are attempted - -- in different exploration branches. Once a search branch exhausts - -- all dependencies, successfully solved or not, it is added to the - -- following global pool of solutions. The search status in each branch - -- is stored in a number of trees that are the arguments of the Expand - -- internal procedure, and in a Solution that is being incrementally - -- built. - - Solutions : Solution_Sets.Set; - -- We store here all solutions found. The solver is currently exhaustive - -- in that it will not stop after the first solution, but will keep - -- going until all possibilities are exhausted. If, at some point, - -- resolution starts to take too much time, it may be useful to be able - -- to select the solver behavior (e.g. stop after the first complete - -- solution is found). + -- On the solver internal operation: the solver tries all possible + -- dependency combinations, using a state queue roughly ordered by + -- solution quality. This means that, for a given dependency, all + -- satisfying releases are attempted in different exploration branches. + -- Once a search branch exhausts all dependencies, successfully solved + -- or not, it is added to the following global pool of solutions. The + -- search status in each branch is stored in a number of trees that are + -- the arguments of the Expand internal procedure, and in a Solution + -- that is being incrementally built. Tools : constant Releases.Containers.Release_Set := Toolchains.Available @@ -276,87 +316,46 @@ package body Alire.Solver is -- Installed releases do not change during resolution, we make a local -- copy here so they are not read repeatedly from disk. - Dupes : Natural := 0; - -- Some solutions are found twice when some dependencies are subsets of - -- other dependencies. - - Complete : Natural := 0; -- Counter of complete solutions for speed-up - - User_Answer_Continue : CLIC.User_Input.Answer_Kind := - CLIC.User_Input.Yes; - -- Answer given by the user to the question of continuing search. By - -- default we will ask on first timeout. + ----------------------- + -- Selected_Compiler -- + ----------------------- - -------------------------- - -- Ask_User_To_Continue -- - -------------------------- + package Selected_Compiler is - procedure Ask_User_To_Continue is - use CLIC.User_Input; - begin - Timer.Hold; + Exists : constant Boolean + := Toolchains.Tool_Is_Configured (GNAT_Crate); + -- Cached to avoid multiple look-ups - if Not_Interactive - or else Options.On_Timeout = Stop - or else User_Answer_Continue = No - then - Trace.Debug ("Forcing stop of solution search after " - & Timer.Image & " seconds"); - raise Solution_Timeout; - end if; + function Milestone return Milestones.Milestone; - if Solutions.Is_Empty then - Put_Warning ("No solution found after " - & Timer.Image (Decimals => 0) - & " seconds."); + private - else - if not Solutions.First_Element.Is_Complete then - Put_Warning ("Complete solution not found after " - & Timer.Image (Decimals => 0) - & " seconds."); - Put_Info ("The best incomplete solution yet is:"); - else - Put_Warning ("Solution space not fully explored after " - & Timer.Image (Decimals => 0) - & " seconds."); - Put_Info ("The best complete solution yet is:"); - end if; + Selected_Compiler_Milestone : constant Milestones.Milestone + := (if Exists + then Toolchains.Tool_Milestone (GNAT_Crate) + else Milestones.New_Milestone ("gnat_not_configured=0.0")); + -- Cached to avoid multiple look-ups - Trace.Info (""); - Solutions.First_Element.Print_States (Level => Trace.Info); - Trace.Info (""); - end if; + function Milestone return Milestones.Milestone + is (if Exists + then Selected_Compiler_Milestone + else raise Program_Error with "No default compiler is selected"); - -- Options take precedence over any interaction yet to occur + end Selected_Compiler; - if Options.On_Timeout = Continue - or else - (Options.On_Timeout = Continue_While_Complete_Then_Stop - and then Options.Completeness < Some_Incomplete) - then - User_Answer_Continue := Always; - end if; + Dupes : Natural := 0; + -- Some solutions are found twice when some dependencies are subsets of + -- other dependencies. - -- If interaction still allowed, ask the user what to on timeout + Unfeasible : Natural := 0; + -- Some generated states are unfeasible due to conflicting dependencies - if User_Answer_Continue /= Always then - User_Answer_Continue := Query - (Question => - "Do you want to keep solving for a few more seconds?", - Valid => (others => True), - Default => (if Not_Interactive then No else Yes)); - end if; + Complete : Natural := 0; -- Counter of complete solutions for speed-up - if User_Answer_Continue /= No then - Timeout := Timeout + Options.Timeout_More; - Timer.Release; - else - Trace.Debug ("User forced stop of solution search after " - & Timer.Image & " seconds"); - raise Solution_Timeout; - end if; - end Ask_User_To_Continue; + User_Answer_Continue : CLIC.User_Input.Answer_Kind := + CLIC.User_Input.Yes; + -- Answer given by the user to the question of continuing search. By + -- default we will ask on first timeout. ------------------------------ -- Contains_All_Satisfiable -- @@ -368,7 +367,7 @@ package body Alire.Solver is -- because it doesn't exist. function Contains_All_Satisfiable (Solution : Alire.Solutions.Solution) - return Boolean is + return Boolean is begin for Crate of Solution.Crates loop if Solution.State (Crate).Fulfilment in Missed | Hinted @@ -388,12 +387,412 @@ package body Alire.Solver is return True; end Contains_All_Satisfiable; + ----------------------------- + -- Is_Potentially_Complete -- + ----------------------------- + + function Is_Potentially_Complete (This : in out Search_State) + return Boolean + is (Contains_All_Satisfiable (This.Solution)); + + -------------------- + -- Image_One_Line -- + -------------------- + + function Image_One_Line (State : Search_State) return String + is + begin + if Trace.Level = Debug then + return "" + & "i:" & State.Id'Image & "; p:" & State.Parent'Image & "; " + & "COMPLETE: " + & Contains_All_Satisfiable (State.Solution)'Image & "/" + & Contains_All_Satisfiable (State.To_Solution)'Image & "; " + & "DOWN:" & State.Downgrade'Image & "; " + & "TARGET: " & State.Target.Image_One_Line & "; " + & "SEEN: " & State.Seen.Image_One_Line & "; " + & "EXPANDED: " & State.Expanded.Image_One_Line & "; " + & "REMAIN: " & State.Remaining.Image_One_Line & "; " + ; + else + return ""; + end if; + end Image_One_Line; + + --------------- + -- Is_Better -- + --------------- + -- This function is a key element of the solver, which should steer it + -- to the optimal complete solution first, and then to progressively + -- worse solutions. Also, it causes the compiler order preferences to be + -- applied. In practice this should be equivalent to an A* search, with + -- the number of remaining unsolved dependencies as the heuristic. + function Is_Better (L, R : in out Search_State) return Boolean + is + use all type Utils.Comparisons.Result; + use all type Utils.Comparisons.Bool_Result; + use type Alire.Solutions.Compositions; + + function Compare is + new Utils.Comparisons.Compare (Alire.Solutions.Compositions); + function Compare is + new Utils.Comparisons.Compare (Natural); + + LS : Solution renames L.Solution; + RS : Solution renames R.Solution; + + ------------------------ + -- Preferred_Compiler -- + ------------------------ + + function Preferred_Compiler return Utils.Comparisons.Result is + + function L_GNAT return Release + is (LS.Releases_Providing (GNAT_Crate).First_Element); + function R_GNAT return Release + is (RS.Releases_Providing (GNAT_Crate).First_Element); + + ----------------------- + -- Preferred_Version -- + ----------------------- + + function Preferred_Version (L, R : Semver.Version) + return Utils.Comparisons.Result + is + use type Semver.Version; + begin + if L = R then + return Equal; + else + case Options.Age is + when Newest => return (if L > R then Left else Right); + when Oldest => return (if L < R then Left else Right); + end case; + end if; + end Preferred_Version; + + use Utils; + + begin + -- Preferred compiler order is, according to our docs and tests: + -- - No specific compiler at all + -- - The selected compiler, if defined + -- - An externally available compiler + -- - Newest installed native compiler + -- - Newest installed cross-compiler + -- - Newest uninstalled explicit native compiler + -- - Newest uninstalled explicit cross-compiler + + -- - No specific compiler at all + + case Comparisons.Which_One + (LS.Releases_Providing (GNAT_Crate).Is_Empty, + RS.Releases_Providing (GNAT_Crate).Is_Empty) + is + when Left => return Left; + when Right => return Right; + when Both => return Equal; + when None => + null; + -- Both depend on some GNAT, we have to disambiguate next + end case; + + -- - The selected compiler, if defined + + if Selected_Compiler.Exists then + case Comparisons.Which_One + (LS.Contains (Selected_Compiler.Milestone), + RS.Contains (Selected_Compiler.Milestone)) + is + when Left => return Left; + when Right => return Right; + when Both => return Equal; + when None => null; -- Keep on disambiguating + end case; + end if; + + -- Prefer external compilers + + case Comparisons.Which_One + (not LS.Releases_Providing (GNAT_Crate).Is_Empty and then + not L_GNAT.Origin.Is_Index_Provided, + not RS.Releases_Providing (GNAT_Crate).Is_Empty and then + not R_GNAT.Origin.Is_Index_Provided) + is + when Left => return Left; + when Right => return Right; + when Both => + -- Prefer according to version policy + return Preferred_Version + (L_GNAT.Version, + R_GNAT.Version); + when None => null; -- Keep on disambiguating + end case; + + -- Prefer newest installed native compiler + + case Comparisons.Which_One + (LS.Contains_Release (GNAT_Native_Crate) and then + Tools.Contains (L_GNAT) + , + RS.Contains_Release (GNAT_Native_Crate) and then + Tools.Contains (R_GNAT) + ) + is + when Left => return Left; + when Right => return Right; + when Both => + -- Prefer newest/oldest according to policy + return Preferred_Version + (L_GNAT.Version, + R_GNAT.Version); + when None => + null; -- Keep on disambiguating + end case; + + -- Prefer newest installed any (cross) compiler + + case Comparisons.Which_One + (not LS.Releases_Providing (GNAT_Crate).Is_Empty and then + Tools.Contains (L_GNAT) + , + not RS.Releases_Providing (GNAT_Crate).Is_Empty and then + Tools.Contains (R_GNAT) + ) + is + when Left => return Left; + when Right => return Right; + when Both => + -- Prefer newest/oldest according to policy + return Preferred_Version + (L_GNAT.Version, + R_GNAT.Version); + when None => + null; -- Keep on disambiguating + end case; + + -- At this point no installed compiler is in any solution, so we + -- just check first a native compiler and then any compiler, no + -- matter their installation status. + + -- Prefer native compiler + + case Comparisons.Which_One + (L.Solution.Contains_Release (GNAT_Native_Crate), + R.Solution.Contains_Release (GNAT_Native_Crate)) + is + when Left => return Left; + when Right => return Right; + when Both => + -- Prefer newest/oldest according to policy + return Preferred_Version + (L_GNAT.Version, + R_GNAT.Version); + when None => + null; -- Keep on disambiguating + end case; + + -- Prefer newest installed any (cross) compiler + + case Comparisons.Which_One + (not LS.Releases_Providing (GNAT_Crate).Is_Empty, + not RS.Releases_Providing (GNAT_Crate).Is_Empty) + is + when Left => return Left; + when Right => return Right; + when Both => + -- Prefer newest/oldest according to policy + return Preferred_Version + (L_GNAT.Version, + R_GNAT.Version); + when None => + null; -- Keep on disambiguating + end case; + + return Equal; + end Preferred_Compiler; + + use Utils; + + begin + + -- TODO: all the following comparisons will be performed N log + -- N times when inserting a new state, and some use expensive + -- arguments. We might try caching all of those (since we have + -- a pointer to the state in place) on first use and see if it + -- improves search times. KCacheGrind summary inspection points to + -- Contains_All_Satisfiable as the primary culprit. However, caching + -- it results in no gain, so most calls to it are unique and the + -- speed-up should focus on the function proper. + + -- Prefer states that might lead to a complete solution (those + -- include states that already are completely explored). + + case Comparisons.Which_One + (Is_Potentially_Complete (L), + Is_Potentially_Complete (R)) + is + when Left => return True; + when Right => return False; + when Both | None => null; + end case; + + -- Prefer states according to compiler priorities + + case Preferred_Compiler is + when Left => return True; + when Right => return False; + when Equal => null; + end case; + + -- Prefer solutions with better completions (given the first + -- criterion on completed first, this only affects the first + -- incomplete solution to be found if there are no complete ones). + + case Compare (L.Solution.Composition, R.Solution.Composition) is + when Left => return True; + when Right => return False; + when Equal => null; + end case; + + -- Prefer solutions with more dependencies evaluated (depth-first + -- search within the previous breadth-first criteria) + + case Compare (Natural (L.Solution.All_Dependencies.Length), + Natural (R.Solution.All_Dependencies.Length)) + is + when Left => return False; + when Right => return True; + when Equal => null; + end case; + + -- Prefer solutions with fewer downgrades/upgrades. This is to + -- avoid that an older dependency that in turns introduces fewer + -- dependencies be favored over a newer dependency. (Note that when + -- the age policy is Oldest, this is reversed an means unwanted + -- upgrades.) + + case Compare (L.Downgrade, R.Downgrade) is + when Left => return True; + when Right => return False; + when Equal => null; + end case; + + -- Prefer states with fewer pending dependencies. This is simply to + -- steer the search towards complete solutions first. + + case Compare (Pending_Count (L), Pending_Count (R)) is + when Left => return True; + when Right => return False; + when Equal => null; + end case; + + -- All else being equal, the best solution is preferred + + case Comparisons.Which_One + (L.Solution.Is_Better (R.Solution), + R.Solution.Is_Better (L.Solution)) + is + when Left => return True; + when Right => return False; + when Both | None => null; -- Check other things + end case; + + -- If we have reached the same solution from two branches (should + -- check if this can happen), disambiguate with the state ID. This + -- might be an impossible situation? + + return L.Id < R.Id; -- Can't be equal + end Is_Better; + + --------- + -- "<" -- + --------- + + function "<" (L, R : State_Ptr) return Boolean + is (Is_Better (L.all, R.all)); + + package State_Sets is new Ada.Containers.Indefinite_Ordered_Sets + (Element_Type => State_Ptr); + + -- This package is used to ensure consistent behaviors when accessing + -- the best solution found. + package Solutions is + procedure Include (Final_State : State_Ptr); + function First return Alire.Solutions.Solution; + function Length return Natural; + function Is_Trivial return Boolean; + -- Says if the first known solution is the trivial one (everything + -- missing:skipped). This solution sometimes is valid when there's + -- only unsolvable dependencies, as we do in some tests, so it would + -- be considered a complete solution. However, by allowing the solver + -- to proceed, it will find the reason for the missing dependencies, + -- which is preferable. IOWs, it's just a corner case to preserve + -- old behavior. + private + Trivial_Removed : Boolean := False; + -- We store a trivial solution to ensure that there is always one + -- available, but we discard it as soon as a proper one is stored. + + States : State_Sets.Set; + -- We store here all terminal state solutions. To reuse the state + -- sorting, which is more comprehensive than solution sorting, + -- we store them with the whole state. In practice, we could move + -- comparison of solutions (Solutions.Is_Better) inside state + -- comparison, as it isn't used elsewhere. + end Solutions; + + package body Solutions is + + ---------------- + -- Is_Trivial -- + ---------------- + + function Is_Trivial return Boolean is (not Trivial_Removed); + + ------------- + -- Include -- + ------------- + + procedure Include (Final_State : State_Ptr) is + begin + if States.Length = 1 and then not Trivial_Removed then + States.Delete_First; + Trivial_Removed := True; + Trace.Debug ("SOLVER: trivial solution dropped"); + end if; + + States.Include (Final_State); + end Include; + + -------------------- + -- First_Solution -- + -------------------- + + function First return Alire.Solutions.Solution is + begin + return States.First_Element.To_Solution; + end First; + + ------------ + -- Length -- + ------------ + + function Length return Natural is (Natural (States.Length)); + + end Solutions; + + States : State_Sets.Set; + -- To avoid possibly deep recursivity that also may not find the best + -- solution by doing a depth-first search, we keep a priority queue of + -- unexplored states. + ------------- -- Partial -- ------------- function Partial return Natural - is (Natural (Solutions.Length) - Complete); + is (Solutions.Length - Complete); ------------------- -- Progress_Line -- @@ -406,9 +805,11 @@ package body Alire.Solver is return "Solving dependencies: " & Trim (Complete'Img) & "/" & Trim (Partial'Img) & "/" - & Trim (Dupes'Image) & "/" + & Trim (Dupes'Image) & "//" + & Trim (States.Length'Image) & "/" + & Trim (Unfeasible'Image) & "/" & Trim (Next_Id'Image) - & " (complete/partial/dupes/states)"; + & " (ok/part/dup//queue/bad/total)"; end Progress_Line; --------------------- @@ -423,6 +824,139 @@ package body Alire.Solver is end if; end Progress_Report; + -------------------- + -- Store_Solution -- + -------------------- + + procedure Store_Solution (State : State_Ptr) is + Pre_Length : constant Natural := Solutions.Length; + + Solution : constant Alire.Solutions.Solution := State.To_Solution; + Pending : constant Natural := State.Pending_Count; + begin + Trace.Debug ("SOLVER: state " + & (if Pending = 0 + then "(TERMINAL)" + else "(pending deps:" & Pending'Image & ")") + & " solved as: " + & Solution.Image_One_Line + & " complete: " & Solution.Is_Complete'Img + & "; composition: " & Solution.Composition'Img); + + Solutions.Include (State); + + if Pre_Length = Solutions.Length then + Dupes := Dupes + 1; + elsif Solution.Is_Complete then + Complete := Complete + 1; + end if; + + Progress_Report; + end Store_Solution; + + ------------- + -- Enqueue -- + ------------- + + procedure Enqueue (Action : String; + This : access Search_State) is + + --------------------- + -- Clean_Remaining -- + --------------------- + + procedure Clean_Remaining is + Remain : Conditional.Dependencies; + Seen : Dependencies.Containers.Set; + begin + -- Consolidate all pending dependencies in a single vector, taking + -- the opportunity to filter out already-seen dependencies. This + -- is an optimization that should not alter the result (but it + -- significantly speeds up the search). + + for Dep of + Conditional.Dependencies'(This.Target and This.Remaining) + loop + if (Dep.Is_Value + and then not Seen.Contains (Dep.Value) + and then not This.Seen.Contains (Dep.Value) + and then not -- Both seen and solved already + (This.Solution.Depends_Directly_On (Dep.Value.Crate) + and then This.Solution.Satisfies (Dep.Value)) + ) + or else not Dep.Is_Value + then + Remain.Append (Dep); + Seen.Insert (Dep.Value); + end if; + end loop; + + if Remain.Is_Empty then + This.Target := Conditional.No_Dependencies; + This.Remaining := Conditional.No_Dependencies; + else + This.Target := Remain.First_Child; + This.Remaining := Remain.All_But_First_Children; + end if; + end Clean_Remaining; + + -------------- + -- Feasible -- + -------------- + + function Feasible return Boolean is + begin + return not + -- Unfeasibility check: some remaining dependency, which is not + -- solved via pin, is already incompatible with a release in the + -- solution. TODO: some pin, known since the very beginning, may + -- provide crates which evade this check. To be implemented down + -- the road (this was missing also in the old solver). + (for some Dep of Conditional.Dependencies' + (This.Target and This.Remaining) + => + Dep.Is_Value + and then + not Pins.Depends_On (Dep.Value.Crate) + and then + This.Solution.Contains_Release (Dep.Value.Crate) + and then not This.Solution.State + (Dep.Value.Crate).Release.Satisfies (Dep.Value)); + end Feasible; + + Count : constant Natural := Natural (States.Length); + begin + + Clean_Remaining; + -- Optimizations to speed-up search and avoid infinite re-evaluation + -- of already seen dependencies. + + if not Feasible then + Unfeasible := Unfeasible + 1; + Trace.Debug ("SOLVER: DROP id" & This.Id'Image & " " + & Action + & " STATE " & Image_One_Line (This.all)); + return; + end if; + + Trace.Debug ("SOLVER: ENQUEUE id" & This.Id'Image & " " + & Action + & " STATE " & Image_One_Line (This.all)); + + States.Insert (State_Ptr'(This.all'Unchecked_Access)); + -- This is safe to do because the pointer was originally already of + -- type State_Ptr, but the direct conversion raises accessibility + -- check spuriously. + + if Natural (States.Length) = Count then + raise Program_Error with "Search state lost!"; + end if; + + if Pending_Count (This.all) = 0 then + Store_Solution (State_Ptr'(This.all'Unchecked_Access)); + end if; + end Enqueue; + ------------ -- Expand -- ------------ @@ -431,7 +965,17 @@ package body Alire.Solver is is use Dependencies.Containers; - St : Search_State renames State; + ------------------- + -- Find_Conflict -- + ------------------- + -- Check if the given dependency is conflicting with some remaining + -- dependency. Of course this may miss still unknown transitive + -- dependencies, but for simple cases it will enhance our reporting. + function Find_Conflict (Mil : Milestones.Milestone) return Boolean + is (for some Pending of State.Remaining => + Pending.Is_Value and then + Mil.Crate = Pending.Value.Crate and then + not Semver.Extended.Is_In (Mil.Version, Pending.Value.Versions)); ------------------ -- Expand_Value -- @@ -453,308 +997,197 @@ package body Alire.Solver is -- dependency invalid, it should be checked again (which Check -- below does.) - -------------------- - -- Check_Compiler -- - -------------------- - - function Check_Compiler (R : Release) return Boolean is - - ------------------- - -- Specific_GNAT -- - ------------------- - -- Examine pending dependencies for a specific GNAT, and if so - -- return the one. - function Specific_GNAT (Deps : Conditional.Dependencies) - return Conditional.Dependencies - is - begin - if Deps.Is_Iterable then - for Dep of Deps loop - if AAA.Strings.Has_Prefix (Dep.Value.Crate.As_String, - "gnat_") -- Ugly hack - then - return Dep; - end if; - end loop; - end if; - - return Conditional.No_Dependencies; - end Specific_GNAT; - - Result : Boolean := False; + ------------------ + -- Check_Hinted -- + ------------------ + function Check_Hinted return Boolean is begin - - -- The following checks are not guaranteed to find the proper - -- GNAT to use, as a yet-unknown dependency might add a precise - -- GNAT later on. It should however cover the common case - -- in which the GNAT dependencies are in the root crate. If - -- all else fails, in the end there is a real problem of the - -- user having selected an incompatible compiler, so the last - -- recourse is for the user to unselect the compiler in this - -- configuration local config, for example. - - if Solution.Depends_On_Specific_GNAT then - - -- There is already a precise gnat_xxx in the solution, that - -- we can reuse. - - Result := - (for some Prev of Solution.Releases_Providing (GNAT_Crate) - => Prev.Name = R.Name); - - Trace.Debug - ("SOLVER: gnat PASS " & Result'Image - & " for " & R.Milestone.TTY_Image - & " due to compiler already in solution: " - & Solution.Releases.Elements_Providing - (GNAT_Crate).Image_One_Line); - - return Result; - - elsif not Specific_GNAT (State.Remaining).Is_Empty then - - -- There is an unsolved dependency on a specific gnat, that - -- we must honor sooner or later, so no point on trying - -- another target. - - Trace.Debug - ("SOLVER: gnat PASS " & Boolean' - (R.Satisfies (Specific_GNAT (St.Remaining).Value))'Img - & " for " & R.Milestone.TTY_Image - & " due to compiler already in dependencies: " - & Specific_GNAT (State.Remaining).Value.TTY_Image); - - return R.Satisfies (Specific_GNAT (St.Remaining).Value); - - elsif Toolchains.Tool_Is_Configured (GNAT_Crate) - and then Options.Completeness = First_Complete - -- When we cannot find a complete solution in the first - -- completeness level, this means we need a compiler that - -- is not installed, and then we avoid this branch which - -- forces the selected compiler even if unavailable. - then - - -- There is a preferred compiler that we must use, as there - -- is no overriding reason not to - - Trace.Debug - ("SOLVER: gnat PASS " & Boolean' - (R.Satisfies - (Toolchains.Tool_Dependency (GNAT_Crate)))'Img - & " for " & R.Milestone.TTY_Image - & " due to configured compiler: " - & Toolchains.Tool_Dependency (GNAT_Crate).TTY_Image); - - return R.Satisfies (Toolchains.Tool_Dependency (GNAT_Crate)); - - elsif Dep.Crate = GNAT_Crate then - - -- For generic dependencies on gnat, we do not want to use a - -- compiler that is not already installed, unless we failed - -- on the First_Complete level. - + if Index.Has_Externals (Dep.Crate) then + if Options.Hinting = Hint then + Enqueue + ("HINTED: " & (+Dep.Crate) & + " via EXTERNAL to satisfy " & Dep.Image & + " w/o adding deps to tree ", + Next (State) + .Seeing (Raw_Dep) + .Targeting (State.Remaining) + .With_More (Empty) + .Solved (Solution.Hinting (Dep))); + return True; + else + Trace.Debug + ("SOLVER: dependency not hinted: " & (+Dep.Crate) & + " as HINTING is DISABLED, for dep " & Dep.Image & + " having externals, when tree is " & + Image_One_Line (State)); + end if; + else Trace.Debug - ("SOLVER: gnat PASS " & Boolean' - (Tools.Contains (R) - or else Options.Completeness > First_Complete)'Image - & " for " & R.Milestone.TTY_Image - & " due to installed compiler availability."); - - -- On first attempt we prefer only installed GNATs, but - -- we allow a not-installed available one if no complete - -- solution could be found otherwise. - return Tools.Contains (R) - or else Options.Completeness > First_Complete; + ("SOLVER: dependency not hinted: " & (+Dep.Crate) & + " for dep " & Dep.Image & + " LACKING externals, when tree is " & + Image_One_Line (State)); + end if; - else + return False; + end Check_Hinted; - Trace.Debug ("SOLVER: gnat compiler " & R.Milestone.TTY_Image - & " is valid candidate."); + -------------------- + -- Expand_Missing -- + -------------------- + -- Mark a crate as missing and continue exploring, depending on + -- configuration policies, or abandon this search branch. + procedure Expand_Missing + (Reason : Dependencies.States.Missed_Reasons) + is + begin - return True; + -- When we can hint, do so instead of simply reporting the + -- crate as unavailable, but only when there is no conflict + if Reason in Skipped | Unavailable then + if Check_Hinted then + return; + end if; end if; - end Check_Compiler; - ----------- - -- Check -- - ----------- + -- If no reason to hint, plain missing + + Enqueue + ("marking MISSING:" & Reason'Image & " crate " & Dep.Image, + Next (State) + .Seeing (Raw_Dep) + .Targeting (State.Remaining) + .With_More (Empty) + .Solved (Solution.Missing (Dep, Reason))); + end Expand_Missing; - procedure Check (R : Release; - Is_Reused : Boolean) + ------------------- + -- Check_Release -- + ------------------- + + procedure Check_Release + (R : Release; + -- The release to check for inclusion in the solution + Is_Reused : Boolean; + -- When this release is already in the solution, we know it + -- this way for speed-up (no need to look in the solution + -- again). + Downgrade : Natural + -- Likewise, if this release is not the best for the + -- dependency, the amount of downgrades is known at the + -- point of the call. + ) is begin - -- Special compiler checks are hardcoded when the dependency is - -- on a generic GNAT. This way we ensure the preferred compiler - -- is used, unless we are forced by other dependencies to do - -- something else - - if Dep.Crate = GNAT_Crate and then - R.Provides (GNAT_Crate) and then - not Check_Compiler (R) - then - -- Reason already logged by Check_Compiler - return; - end if; + -- Compiler checks were done here in the old solver. We may + -- need to reintroduce them for speed up, but they should not + -- affect the new priority-based search final result, which + -- removes a lot of complicated ad-hoc logic. -- If the candidate release is forbidden by a previously -- resolved dependency, the candidate release is -- incompatible and we may stop search along this branch. - if Solution.Forbids (R, Props) then + if not Is_Reused and then Solution.Forbids (R, Props) then Trace.Debug - ("SOLVER: discarding tree because of" & + ("SOLVER: discarding branch because of" & " FORBIDDEN release: " & R.Milestone.Image & " forbidden by current solution when tree is " & Image_One_Line (State)); - -- After all these checks, the candidate release must belong to - -- a crate that is still unfrozen, so it is a valid new crate - -- and release to consider. First, check version compliance: + Expand_Missing (Conflict); + return; + end if; + + -- First, check version compliance: - elsif not R.Satisfies (Dep) then + if not R.Satisfies (Dep) then Trace.Debug - ("SOLVER: discarding search branch because " + ("SOLVER: discarding branch because " & R.Milestone.Image & " FAILS to fulfill dependency " & Dep.TTY_Image & " when the search tree was " & Image_One_Line (State)); - -- Even if the release is OK for the dependency, the - -- aggregated dependencies for the crate in the solution - -- can be another matter, so we recheck again. + if Is_Reused then + Expand_Missing (Conflict); + end if; - elsif not R.Satisfies (Solution.Dependency (Dep.Crate)) then - Trace.Debug - ("SOLVER: discarding search branch because " - & R.Milestone.Image & " FAILS to fulfill dep-in-solution " - & Solution.Dependency (Dep.Crate).TTY_Image - & " when the search tree was " - & Image_One_Line (State)); + return; + end if; -- Or it may be that, even being a valid version, it's not for -- this environment. - elsif not R.Is_Available (Props) then - + if not R.Is_Available (Props) then Trace.Debug - ("SOLVER: discarding search branch because " + ("SOLVER: discarding branch because " & R.Milestone.Image & " is UNAVAILABLE" & " when the search tree was " & Image_One_Line (State)); - -- If we reached here, the release fulfills the dependency, so - -- we add it to the solution. It might still be a release that - -- fulfilled a previous dependency, so we take care of that - -- when adding its dependencies. - - else - declare - -- We only need to add dependencies if it is the first - -- time we see this release. - New_Deps : constant Conditional.Platform_Dependencies := - (if Is_Reused - then Conditional.No_Dependencies - else R.Dependencies (Props)); - begin - Trace.Debug - ("SOLVER: dependency FROZEN: " & R.Milestone.Image & - " to satisfy " & Dep.TTY_Image & - (if Is_Reused then " with REUSED" else "") & - (if not R.Provides.Is_Empty - then " also providing " & R.Provides.Image_One_Line - else "") & - " adding" & New_Deps.Leaf_Count'Img & - " dependencies to tree " & - Image_One_Line (State) & - "; NEW: " & New_Deps.Image_One_Line); - - Expand ((Id => <>, - Parent => State.Id, - Seen => State.Seen.Union (To_Set (Raw_Dep)), - Expanded => State.Expanded and R.To_Dependency, - Target => State.Remaining, - Remaining => New_Deps, - Solution => Solution.Including - (R, Props, - For_Dependency => - Optional.Crate_Names.Unit (Dep.Crate)))); - end; + Expand_Missing (Unavailable); + return; end if; - end Check; - -------------------- - -- Expand_Missing -- - -------------------- - -- Mark a crate as missing and continue exploring, depending on - -- configuration policies, or abandon this search branch. - procedure Expand_Missing - (Reason : Dependencies.States.Missed_Reasons) - is - begin - if Options.Completeness > All_Complete or else - Unavailable_Crates.Contains (Raw_Dep.Crate) or else - Unavailable_Direct_Deps.Contains (Raw_Dep) + -- The release might provide a dependency already fulfilled, + -- in which case we must drop it. Note that two releases may + -- provide the same third crate, as long as this third crate + -- is not an actual dependency, and this is valid. + + if not Is_Reused and then Solution.Contains_Incompatible (R) then Trace.Debug - ("SOLVER: marking MISSING the crate " & Dep.Image - & " when the search tree was " - & Image_One_Line (State)); + ("SOLVER: discarding branch because of" & + " PROVIDED release: " & + R.Milestone.Image & + " already provided by current solution when tree is " & + Image_One_Line (State)); - Expand ((Id => <>, - Parent => State.Id, - Seen => State.Seen.Union (To_Set (Raw_Dep)), - Expanded => State.Expanded and Raw_Dep, - Target => State.Remaining, - Remaining => Empty, - Solution => Solution.Missing (Dep, Reason))); - else - Trace.Debug - ("SOLVER: discarding solution MISSING crate " & Dep.Image - & " when the search tree was " - & Image_One_Line (State)); + Expand_Missing (Conflict); + return; end if; - end Expand_Missing; - ------------------ - -- Check_Hinted -- - ------------------ - - procedure Check_Hinted is - begin - if Index.Has_Externals (Dep.Crate) then - if Options.Hinting = Hint then - Trace.Debug - ("SOLVER: dependency HINTED: " & (+Dep.Crate) & - " via EXTERNAL to satisfy " & Dep.Image & - " without adding dependencies to tree " & - Image_One_Line (State)); + -- If we reached here, the release fulfills the dependency, so + -- we add it to the solution. It might still be a release that + -- fulfilled a previous dependency, so we take care of that + -- when adding its dependencies. - Expand ((Id => <>, - Parent => State.Id, - Seen => State.Seen.Union (To_Set (Raw_Dep)), - Expanded => State.Expanded, - Target => State.Remaining, - Remaining => Empty, - Solution => Solution.Hinting (Dep))); - else - Trace.Debug - ("SOLVER: dependency not hinted: " & (+Dep.Crate) & - " as HINTING is DISABLED, for dep " & Dep.Image & - " having externals, when tree is " & - Image_One_Line (State)); - end if; - else - Trace.Debug - ("SOLVER: dependency not hinted: " & (+Dep.Crate) & - " for dep " & Dep.Image & - " LACKING externals, when tree is " & - Image_One_Line (State)); - end if; - end Check_Hinted; + declare + -- We only need to add dependencies if it is the first + -- time we see this release. + New_Deps : constant Conditional.Platform_Dependencies := + (if Is_Reused + then Conditional.No_Dependencies + else R.Dependencies (Props)); + begin + Enqueue + ("FROZEN: " & R.Milestone.Image & + " to satisfy " & Dep.TTY_Image & + (if Is_Reused then " REUSED" else " NEW") & + (if not R.Provides.Is_Empty + then " also PROVIDING " & R.Provides.Image_One_Line + else "") & + " adding" & New_Deps.Leaf_Count'Img & + " dependencies to tree " & + "ADDS: " & New_Deps.Image_One_Line, + Next (State) + .Downgrading (Downgrade) + .Seeing (Raw_Dep) + .Expanding (R) + .Targeting (State.Remaining) + .With_More (New_Deps) + .Solved + (Solution.Including + (R, Props, + For_Dependency => + Optional.Crate_Names.Unit (Dep.Crate)))); + end; + end Check_Release; ----------------------- -- Check_Version_Pin -- @@ -787,25 +1220,31 @@ package body Alire.Solver is Trace.Debug ("SOLVER short-cutting due to version pin" & " with valid release in index"); - Check (Release, Is_Reused => False); + Check_Release (Release, + Is_Reused => False, + Downgrade => 0); end loop; -- There may be no satisfying releases, or even so the -- check may still fail, so we must attempt this one too: - if Options.Completeness >= Some_Incomplete then + if not State.Seen.Contains (Raw_Dep) then Trace.Debug ("SOLVER: marking crate " & Dep.Image & " MISSING in case pinned version " & TTY.Version (Pin_Version.Image) + & " within " & Dep.Versions.Image & " is incompatible with other dependencies" & " when the search tree was " & Image_One_Line (State)); Expand_Missing - (if Index.Releases_Satisfying (Pin_As_Dep, - Props).Is_Empty + (if Find_Conflict (Milestones.New_Milestone + (Dep.Crate, Pin_Version)) + then Conflict + elsif Index.Releases_Satisfying (Pin_As_Dep, + Props).Is_Empty then Unavailable else Skipped); @@ -828,12 +1267,6 @@ package body Alire.Solver is end if; end Check_Version_Pin; - Satisfiable : Boolean := False; - -- Mark that the dependency is satisfiable. When we refactor the - -- solver from recursive to priority queue (I guess we eventually - -- will have to), we should do this globally since this is - -- information common to all search states. - use type Alire.Dependencies.Dependency; --------------------- @@ -844,43 +1277,144 @@ package body Alire.Solver is -- Call this one whenever the current dependency has been -- already solved so we can skip directly to the next one. begin - Trace.Debug ("SOLVER: SKIP explored (" & Reason & "): " - & Raw_Dep.TTY_Image); - Expand ((Id => <>, - Parent => State.Id, - Seen => State.Seen, - Expanded => State.Expanded, - Target => State.Remaining, - Remaining => Empty, - Solution => State.Solution)); + Enqueue + ("SKIP explored (" & Reason & "): " + & Raw_Dep.TTY_Image, + Next (State) + .Seeing (Raw_Dep) + .Targeting (State.Remaining) + .With_More (Empty)); end Skip_Dependency; - begin + ---------------------------- + -- Check_Regular_Releases -- + ---------------------------- - if Timer.Elapsed > Timeout then - Ask_User_To_Continue; - end if; + procedure Check_Regular_Releases is + begin - -- Early skip if this is a known dependency + -- We may know from the get-go that the dependency cannot be + -- satisfied; in this case don't bother to check candidates. - if State.Seen.Contains (Raw_Dep) then - Skip_Dependency ("seen"); - return; - end if; + if Unavailable_Direct_Deps.Contains (Raw_Dep) or else + Unavailable_All_Deps.Contains (Raw_Dep) + then + Trace.Debug ("SOLVER: skipping known unsatisfiable: " + & Raw_Dep.TTY_Image); + Expand_Missing (Unavailable); + return; + end if; - Progress_Report; -- As this is a new real check + -- Likewise for the combined dependency, in which case there is + -- some conflict. - -- Check if it must be solved with a pin + if Unavailable_Direct_Deps.Contains (Dep) or else + Unavailable_All_Deps.Contains (Dep) + then + Trace.Debug ("SOLVER: skipping known conflict: " + & Raw_Dep.TTY_Image); + Expand_Missing (Conflict); + return; + end if; - if Pins.Depends_On (Dep.Crate) and then - Pins.State (Dep.Crate).Is_Linked - then + -- Some release might satisfy the dependency + + declare + Candidates : constant Releases.Containers.Release_Set := + Index.Releases_Satisfying + (Dep, Props, Index_Query_Options); + Downgrade : Natural := 0; + + -------------- + -- Consider -- + -------------- + + procedure Consider (R : Release) is + begin + Check_Release (R, + Is_Reused => False, + Downgrade => Downgrade); + end Consider; + + begin + Trace.Debug ("SOLVER: considering" + & Candidates.Length'Image & " candidates to " + & Dep.TTY_Image & ": " + & Candidates.Image_One_Line); + + if Candidates.Is_Empty then + Trace.Debug ("SOLVER: marking as unsatisfiable: " + & Dep.TTY_Image); + Unavailable_All_Deps.Include (Dep); + + -- If there are valid releases, though, there is some + -- conflict. We recurse call so this is reported at the + -- beginning. + + if Dep /= Raw_Dep and then + Index.Releases_Satisfying + (Raw_Dep, Props, Index_Query_Options).Is_Empty + then + Unavailable_All_Deps.Include (Raw_Dep); + end if; + Check_Regular_Releases; + -- Recurse after updating the lists of unavailability + + return; + + else + Trace.Debug + ("SOLVER: considering" & Candidates.Length'Image + & " NEW candidates for " & Dep.Image + & ", raw " & Raw_Dep.Image); + if Options.Age = Newest then + for R of reverse Candidates loop + Consider (R); + Downgrade := Downgrade + 1; + end loop; + else + for R of Candidates loop + Consider (R); + Downgrade := Downgrade + 1; + end loop; + end if; + + -- For completeness' sake we can deliberately skip a + -- dependency, which might avoid a conflict later on + -- and provide a decent incomplete solution. We do this + -- only the first time we see a dependency to avoid + -- unnecessary repetition. In truth, we should do this + -- only once per crate, rather that per dependency, but + -- this requires a new field in the state. TODO: do so. + + -- Another positive side effect is that this helps + -- better diagnose some conflicts that would otherwise be + -- missed because exploration would be cut short by the + -- feasibility checks. + + -- In the end, experimental tests with `alr search` show + -- that this does not slow down search anyway. + + if not State.Seen.Contains (Raw_Dep) then + Expand_Missing (Skipped); + end if; + + end if; + end; + end Check_Regular_Releases; + + ---------------- + -- Check_Link -- + ---------------- + + procedure Check_Link is + begin -- Early skip if there is already a pin for this crate caused -- by a different dependency. if Solution.Depends_On (Dep.Crate) and then - Solution.State (Dep.Crate).Is_Linked + Solution.State (Dep.Crate).Is_Linked then Skip_Dependency ("linked"); return; @@ -889,22 +1423,62 @@ package body Alire.Solver is -- The dependency is softlinked in the starting solution, hence -- we need not look further for releases. + Enqueue + ("LINKED to " & + Pins.State (Dep.Crate).Link.Path, + Next (State) + .Seeing (Raw_Dep) + .Expanding + (if Pins.State (Dep.Crate).Has_Release + then Pins.State (Dep.Crate).Release.To_Dependency + else Conditional.No_Dependencies) + .Targeting (State.Remaining) + .With_More (Pins.Pin_Dependencies (Dep.Crate, Props)) + .Solved + (Solution.Linking + (Dep.Crate, Pins.State (Dep.Crate).Link))); + end Check_Link; + + --------------------------- + -- Check_Reused_Releases -- + --------------------------- + + procedure Check_Reused_Releases is + begin Trace.Debug - ("SOLVER: dependency LINKED to " & - Pins.State (Dep.Crate).Link.Path & - " when tree is " & - Image_One_Line (State)); + ("SOLVER: re-checking EXISTING releases " + & Solution.Releases_Providing (Dep.Crate).Image_One_Line + & " for DIFFERENT dep " & Raw_Dep.TTY_Image); - Expand ((Id => <>, - Parent => State.Id, - Seen => State.Seen.Union (To_Set (Raw_Dep)), - Expanded => State.Expanded and Dep, - Target => State.Remaining and - Pins.Pin_Dependencies (Dep.Crate, Props), - Remaining => Empty, - Solution => - Solution.Linking (Dep.Crate, - Pins.State (Dep.Crate).Link))); + for In_Sol of Solution.Dependencies_Providing (Dep.Crate) loop + if In_Sol.Has_Release then + Check_Release (In_Sol.Release, + Is_Reused => True, + Downgrade => 0); + -- If this was a downgrade, it was already counted + end if; + end loop; + end Check_Reused_Releases; + + begin + + -- Early skip if this is a known dependency + + if State.Seen.Contains (Raw_Dep) + or else State.Seen.Contains (Dep) + then + Skip_Dependency ("seen"); + return; + end if; + + Progress_Report; -- As this is a new real check + + -- Check if it must be solved with a link pin + + if Pins.Depends_On (Dep.Crate) and then + Pins.State (Dep.Crate).Is_Linked + then + Check_Link; return; end if; @@ -915,18 +1489,7 @@ package body Alire.Solver is -- result in the same release being used to satisfy the new -- Dep, if possible, or discarding the search branch early. - Trace.Debug - ("SOLVER: re-checking EXISTING releases " - & Solution.Releases_Providing (Dep.Crate).Image_One_Line - & " for DIFFERENT dep " & Raw_Dep.TTY_Image); - - for In_Sol of Solution.Dependencies_Providing (Dep.Crate) loop - if In_Sol.Has_Release then - Check (In_Sol.Release, - Is_Reused => True); - end if; - end loop; - + Check_Reused_Releases; return; end if; @@ -938,124 +1501,19 @@ package body Alire.Solver is -- Specific pin checks that can speed up the search Check_Version_Pin; + return; - elsif Index.Exists (Dep.Crate, Index_Query_Options) + end if; + + if Index.Exists (Dep.Crate, Index_Query_Options) or else Index.All_Crate_Aliases.Contains (Dep.Crate) or else not Index.Releases_Satisfying (Dep, Props, Index_Query_Options).Is_Empty then - -- Check the releases now, from newer to older (unless required - -- in reverse). We keep track that none is valid, as this is - -- a special case in which we're being asked an impossible - -- thing from the start, which we can use to enable a partial - -- solution without exploring the whole solution space: - - if not Unavailable_Direct_Deps.Contains (Raw_Dep) and then - not Unavailable_All_Deps.Contains (Raw_Dep) - then - -- Don't bother checking what we known to not be available. - -- We still want to go through to external hinting. - declare - Candidates : constant Releases.Containers.Release_Set := - Index.Releases_Satisfying - (Dep, Props, Index_Query_Options); - - -------------- - -- Consider -- - -------------- - - procedure Consider (R : Release) is - begin - - -- A GNAT release may still satisfy the dependency - -- but be not a valid candidate if uninstalled and - -- the dependency is on generic GNAT, so explicitly - -- consider this case: - - Satisfiable := Satisfiable or else - (R.Satisfies (Dep) - and then - (Dep.Crate /= GNAT_Crate or else - Tools.Contains (R) or else - Options.Completeness > First_Complete)); - - Check (R, Is_Reused => False); - end Consider; - begin - Trace.Debug ("SOLVER: considering" - & Candidates.Length'Image & " candidates to " - & Dep.TTY_Image & ": " - & Candidates.Image_One_Line); - - if Options.Age = Newest then - for R of reverse Candidates loop - Consider (R); - end loop; - else - for R of Candidates loop - Consider (R); - end loop; - end if; - end; - end if; - - -- If the dependency cannot be satisfied, add it to our damned - -- list for speed-up. - - if not Satisfiable and then - not Unavailable_All_Deps.Contains (Raw_Dep) - then - Trace.Debug ("SOLVER: marking as unsatisfiable: " - & Raw_Dep.TTY_Image); - Unavailable_All_Deps.Include (Dep); - Unavailable_All_Deps.Include (Raw_Dep); - end if; - - -- There may be a less bad solution if we leave this crate out. - - if not Satisfiable or else Options.Completeness = All_Incomplete - then - - -- Beside normal releases, an external may exist for the - -- crate, in which case we hint the crate instead of failing - -- resolution (if the external failed to find its releases). - - if Index.Has_Externals (Dep.Crate) then - - Check_Hinted; - - else - - Trace.Debug - ("SOLVER: marking crate " & Raw_Dep.Image - & " MISSING with Satisfiable=" & Satisfiable'Image - & " when the search tree was " - & Image_One_Line (State)); - - Expand_Missing - (if Satisfiable - then Skipped - -- If satisfiable then we are skipping it in purpose - - elsif State.Solution.Depends_On (Dep.Crate) - then Conflict - -- If not satisfiable and the solution already depends - -- on this crate, then we are seeing a conflict. Note - -- that we use the solution within the state, that - -- still hasn't been informed about the new dependency - -- (otherwise we would always see a conflict). - - else Unavailable - -- The crate is not satisfiable yet there is no - -- conflict, so either there are no valid versions - -- or there are Forbids at play, but we aren't clever - -- enough to discern that (yet?). - ); - - end if; - end if; + Check_Regular_Releases; + return; else @@ -1078,14 +1536,13 @@ package body Alire.Solver is procedure Expand_And_Vector is begin - Expand ((Id => <>, - Parent => State.Id, - Seen => State.Seen, - Expanded => State.Expanded, - Target => State.Target.First_Child, - Remaining => State.Target.All_But_First_Children - and State.Remaining, - Solution => State.Solution)); + Enqueue + ("HEAD", + Next (State) + .Targeting (State.Target.First_Child) + .With_More + (State.Target.All_But_First_Children + and State.Remaining)); end Expand_And_Vector; ---------------------- @@ -1095,76 +1552,43 @@ package body Alire.Solver is procedure Expand_Or_Vector is begin for I in State.Target.Iterate loop - Expand ((Id => <>, - Parent => State.Id, - Seen => State.Seen, - Expanded => State.Expanded, - Target => State.Target (I), - Remaining => State.Remaining, - Solution => State.Solution)); + Enqueue + ("OR", + Next (State) + .Targeting (State.Target (I))); end loop; end Expand_Or_Vector; -------------------- - -- Store_Finished -- + -- Set_New_Target -- -------------------- - procedure Store_Finished (Solution : Alire.Solutions.Solution) is - Pre_Length : constant Count_Type := Solutions.Length; + procedure Set_New_Target is begin - Trace.Debug ("SOLVER: tree FULLY expanded as: " - & State.Expanded.Image_One_Line - & " complete: " & Solution.Is_Complete'Img - & "; composition: " & Solution.Composition'Img); - - Solutions.Include (Solution); - - if Pre_Length = Solutions.Length then - Dupes := Dupes + 1; - elsif Solution.Is_Complete then - Complete := Complete + 1; - end if; - - Progress_Report; -- As we found a new solution - - if Options.Completeness = First_Complete - and then Contains_All_Satisfiable (Solution) - then - raise Solution_Found; -- break recursive search - end if; - end Store_Finished; - - begin - if True or else State.Target.Is_Empty or else State.Target.Is_Value - then - Trace.Debug ("SOLVER: EXPAND"); - Print_Debug (State); - end if; - - if State.Target.Is_Empty then - - -- This is a completed search branch, be the solution complete or - -- not. - - if State.Remaining.Is_Empty then - - Store_Finished (State.Solution); - return; - - else + if not State.Remaining.Is_Empty then -- Take the remaining tree and make it the current target for - -- solving, since we already exhausted the previous target. + -- solving, since we already exhausted the previous target. No + -- need to create a new state in the queue, conceptually this + -- is the next state to explore as there is no solution change. Expand ((Id => <>, Parent => State.Id, + Downgrade => State.Downgrade, Seen => State.Seen, Expanded => State.Expanded, Target => State.Remaining, Remaining => Empty, Solution => State.Solution)); - return; end if; + end Set_New_Target; + + begin + Trace.Debug ("SOLVER: EXPAND " & Image_One_Line (State)); + + if State.Target.Is_Empty then + Set_New_Target; + return; end if; if State.Target.Is_Value then @@ -1211,31 +1635,31 @@ package body Alire.Solver is (Direct : Conditional.Dependencies) is begin - if not Direct.Contains_ORs then - for Dep of Direct loop + for Dep of Conditional.Enumerate (Direct) loop - -- Pre-populate external releases + -- Pre-populate external releases - if Options.Detecting = Detect then - Index.Detect_Externals (Dep.Value.Crate, Props); - end if; + if Options.Detecting = Detect then + Index.Detect_Externals (Dep.Crate, Props); + end if; - -- Regular unavailable releases + -- Regular unavailable releases - if Index.Releases_Satisfying (Dep.Value, Props, - Index_Query_Options).Is_Empty - then - Unavailable_Direct_Deps.Include (Dep.Value); - Trace.Debug - ("Direct dependency has no fulfilling releases: " - & Utils.TTY.Name (Dep.Value.Image)); - end if; + if Index.Releases_Satisfying (Dep, Props, + Index_Query_Options).Is_Empty + and then + not + (Pins.Depends_On (Dep.Crate) and then + Pins.State (Dep.Crate).Is_Linked) + -- Linked crates are solvable, even if not found in index + then + Unavailable_Direct_Deps.Include (Dep); + Trace.Debug + ("Direct dependency has no fulfilling releases: " + & Utils.TTY.Name (Dep.Image)); + end if; - end loop; - else - Trace.Debug ("Alternate dependencies in tree, " - & "speed optimizations disabled."); - end if; + end loop; end Detect_Unavailable_Direct_Dependencies; ---------------- @@ -1258,147 +1682,196 @@ package body Alire.Solver is end if; end Trace_Pins; - Full_Dependencies : constant Conditional.Dependencies := - Tree'(Pins.User_Pins and Deps).Evaluate (Props); - -- Include pins before other dependencies. This makes their dependency - -- show in solutions explicitly. + -------------------- + -- Solution_Found -- + -------------------- - Solution : constant Alire.Solutions.Solution := - Alire.Solutions.Empty_Valid_Solution; - -- Valid solution in the sense that solving has been attempted + function Solution_Found return Boolean is + begin - use all type CLIC.User_Input.Answer_Kind; - begin + -- Keep looking if only trivial available but pending statuses remain - Trace.Detail ("Solving dependencies with options: " & Image (Options)); + if Solutions.Is_Trivial and then not States.Is_Empty then + return False; + end if; - Trace.Detail ("Root dependency tree is: " - & Full_Dependencies.Image_One_Line); - Trace_Pins; + -- If the solution contains all solved dependencies, it is complete + + if Solutions.First.Is_Complete then + Trace.Debug + ("SOLVER: search ended with first COMPLETE solution"); + return True; + elsif Contains_All_Satisfiable (Solutions.First) then + Trace.Debug + ("SOLVER: search ended with first SATISFIABLE solution"); + -- There are missing, but these are not due to conflicts but + -- impossibilities. + return True; + end if; - -- Warn if we foresee things taking a loong time... + -- If we ran out of exploration states, then whatever stored solution + -- there is, is best, but this will be reported elsewhere. - if Options.Completeness = All_Incomplete then - Put_Warning ("Exploring incomplete solutions to dependencies," - & " this may take some time..."); - end if; + if States.Is_Empty then + return False; + end if; - -- Get the trivial case out of the way + -- If there are no potentially complete solutions incoming anymore, + -- we can return already the best incomplete solution. - if Full_Dependencies.Is_Empty then - Trace.Debug ("Returning trivial solution for empty dependencies"); - return Solution; - end if; + declare + Head : constant State_Ptr := States.First_Element; + begin + if Pending_Count (Head.all) = 0 + and then + not Contains_All_Satisfiable (States.First_Element.To_Solution) + then + Trace.Debug + ("SOLVER: search ended with first INCOMPLETE solution"); + Trace.Debug + ("SOLVER: when next state was: " + & Image_One_Line (States.First_Element.all)); + return True; + end if; + end; - -- Preprocess direct dependencies to identify any impossible ones. If - -- the tree contains alternate dependencies this is not doable. + return False; + end Solution_Found; - Detect_Unavailable_Direct_Dependencies (Full_Dependencies); + -------------------- + -- Search_Timeout -- + -------------------- + + function Search_Timeout return Boolean is + + -------------------------- + -- Ask_User_To_Continue -- + -------------------------- + + type Answer is (Stop, Continue); + + function Ask_User_To_Continue return Answer is + use CLIC.User_Input; + begin + Timer.Hold; + + if (Not_Interactive and then not Force) + or else Options.Stopping = Stop + or else User_Answer_Continue = No + then + Trace.Debug ("SOLVER: search timeout after " + & Timer.Image & " seconds"); + return Stop; + end if; + + if not Solutions.First.Is_Complete then + Put_Warning ("Complete solution not found after " + & Timer.Image (Decimals => 0) + & " seconds."); + Put_Info ("The best incomplete solution yet is:"); + else + Put_Warning ("Solution space not fully explored after " + & Timer.Image (Decimals => 0) + & " seconds."); + Put_Info ("The best complete solution yet is:"); + end if; - -- Otherwise expand the full dependencies + Trace.Info (""); + Solutions.First.Print_States (Level => Trace.Info); + Trace.Info (""); + + -- Options take precedence over any interaction yet to occur + + if Options.Stopping = Continue then + User_Answer_Continue := Always; + end if; + + -- If interaction still allowed, ask the user what to on timeout + + if User_Answer_Continue /= Always then + User_Answer_Continue := Query + (Question => + "Do you want to keep solving for a few more seconds?", + Valid => (others => True), + Default => (if Not_Interactive and then not Force + then No + else Yes)); + end if; + + if User_Answer_Continue /= No then + Timeout := Timeout + Options.Timeout_More; + Timer.Release; + else + Trace.Debug ("SOLVER: user forced stop of solution search " + & "after " & Timer.Image & " seconds"); + return Stop; + end if; + + return Continue; + end Ask_User_To_Continue; begin - Expand ((Id => <>, - Parent => 0, - Seen => Dependencies.Containers.Empty_Set, - Expanded => Empty, - Target => Full_Dependencies, - Remaining => Empty, - Solution => Solution)); - exception - when Solution_Timeout => - Trace.Debug ("Solution search ended forcibly before completion"); - when Solution_Found => - Trace.Debug ("Solution search ended with first complete solution"); - end; - - -- Once Expand returns, the recursive exploration has ended. Depending - -- on options, there must exist at least one incomplete solution, or we - -- can retry with a larger solution space. - - if Solutions.Is_Empty - or else not Solutions.First_Element.Is_Complete - then - - -- Inform that no complete solution was found, only when the culprit - -- is not a tool from the toolchain (as that is expected when an - -- uninstalled compiler is needed). - - if Options.Completeness <= All_Complete - and then not Solutions.Is_Empty - and then not Culprit_Is_Toolchain (Solutions.First_Element) - then - Put_Warning ("Spent " & TTY.Emph (Timer.Image) & " seconds " - & "exploring complete solutions"); + if Timer.Elapsed < Timeout then + return False; end if; - -- Now downgrade options to look for more solutions, if allowed and - -- if it makes sense. + return Ask_User_To_Continue = Stop; + end Search_Timeout; - if Options.Completeness < All_Incomplete - and then Options.Exhaustive - and then User_Answer_Continue /= No - and then (Solutions.Is_Empty or else - not Contains_All_Satisfiable (Solutions.First_Element)) - then - Trace.Detail - ("No solution found with completeness policy of " - & Options.Completeness'Image - & "; attempting to find more incomplete solutions..."); - - Progress.Step (Clear => True); -- The nested one will take over - - -- Reattempt so we can return an incomplete solution - - return Resolve - (Deps => Deps, - Props => Props, - Pins => Pins, - Options => - (Query_Options' - (Age => Options.Age, - Completeness => - (case Options.Completeness is - when First_Complete | All_Complete => - Some_Incomplete, - when Some_Incomplete => - All_Incomplete, - when All_Incomplete => - raise Program_Error with "Unreachable code"), - Exhaustive => Options.Exhaustive, - Detecting => Options.Detecting, - Hinting => Options.Hinting, - Timeout => Options.Timeout, - Timeout_More => Options.Timeout_More, - Elapsed => Timer.Elapsed, - On_Timeout => - (if Options.On_Timeout = - Continue_While_Complete_Then_Stop - then Stop - elsif User_Answer_Continue = Always - then Continue - else Options.On_Timeout)))); - elsif Solutions.Is_Empty then - raise Query_Unsuccessful with Errors.Set - ("Solver failed to find any solution to fulfill dependencies " - & "after " & Timer.Image); - end if; - end if; + ------------- + -- Explore -- + ------------- + + procedure Explore is + + procedure Top_Ten is + Remain : Natural := 1; + begin + Trace.Debug ("-- SOLVER STATES --"); + for St of States loop + Trace.Debug ("#" & Remain'Image & ": " + & Image_One_Line (St.all)); - -- In case of finding any solution, we always want to go through this - -- final step of marking transitivity and reporting: + Remain := Remain + 1; + exit when Remain > 9; + end loop; + Trace.Debug ("-------------------"); + end Top_Ten; + + begin + loop + if States.Is_Empty then + Trace.Debug ("SOLVER: solution space exhausted, size:" + & Current_Id'Image); + exit; + end if; + + declare + State : constant State_Ptr := States.First_Element; + begin + States.Delete_First; + -- We could free memory here if we observe large memory use... - if Solutions.Is_Empty then - raise Query_Unsuccessful with Errors.Set - ("Solver failed to find any solution to fulfill dependencies " - & "after " & Timer.Image); - else + Expand (State.all); + end; - -- Mark direct/indirect dependencies post-hoc + Top_Ten; + exit when Solution_Found; + exit when Search_Timeout; + end loop; + end Explore; + + -------------------------- + -- Solution_With_Extras -- + -------------------------- + -- Some extra information not needed during solving is computed for the + -- final solution only. + function Solution_With_Extras return Alire.Solutions.Solution is + begin declare - Best_Solution : Alire.Solutions.Solution := - Solutions.First_Element.With_Pins (Pins); + Best_Solution : Alire.Solutions.Solution + := Solutions.First.With_Pins (Pins); begin -- Mark pins as direct dependencies @@ -1436,7 +1909,7 @@ package body Alire.Solver is & (if not Best_Solution.Hints.Is_Empty then " and" & TTY.Warn (Best_Solution.Hints.Length'Img) - & " external hints" + & " missing external libraries" else "") & (if not Best_Solution.Misses.Is_Empty then " and" @@ -1448,7 +1921,65 @@ package body Alire.Solver is return Best_Solution; end; + end Solution_With_Extras; + + Full_Dependencies : constant Conditional.Dependencies := + Tree'(Pins.User_Pins and Deps).Evaluate (Props); + -- Include pins before other dependencies. This makes their dependency + -- show in solutions explicitly. + + Trivial_Solution : constant Alire.Solutions.Solution := + Alire.Solutions.Empty_Valid_Solution; + -- Valid solution in the sense that solving has been attempted + + begin + + Trace.Detail ("Solving dependencies with options: " & Image (Options)); + + Trace.Detail ("Root dependency tree is: " + & Full_Dependencies.Image_One_Line); + Trace_Pins; + + -- Get the trivial case out of the way + + if Full_Dependencies.Is_Empty then + Trace.Debug + ("SOLVER: returning trivial solution for empty dependencies"); + return Trivial_Solution; end if; + + -- Preprocess direct dependencies to identify any impossible ones + + Detect_Unavailable_Direct_Dependencies (Full_Dependencies); + + -- Create the initial state + + Enqueue ("INITIAL", + State_Ptr' + (new Search_State' + (Id => <>, + Parent => 0, + Downgrade => 0, + Seen => Dependencies.Containers.Empty_Set, + Expanded => Empty, + Target => Full_Dependencies, + Remaining => Empty, + Solution => Trivial_Solution))); + + -- Store a trivially bad solution to ensure there always is a solution + + Solutions.Include (States.First_Element); + + -- Check head state until success or exhaustion + + Explore; + + -- Once Explore returns, we either have a satisfying solution for the + -- stopping criteria, or have fully explored the solution space. In any + -- case, we will have a best solution. + + return Solution_With_Extras; + end Resolve; end Alire.Solver; diff --git a/src/alire/alire-solver.ads b/src/alire/alire-solver.ads index 7eb7d6c7d..25b88ca69 100644 --- a/src/alire/alire-solver.ads +++ b/src/alire/alire-solver.ads @@ -2,12 +2,16 @@ with Alire.Dependencies; with Alire.Index; with Alire.Origins; with Alire.Properties; +with Alire.Releases; with Alire.Solutions; with Alire.Types; with Alire.User_Pins.Maps; with Semantic_Versioning.Extended; +private with Alire.Conditional; +private with Alire.Dependencies.Containers; + package Alire.Solver is -------------- @@ -15,58 +19,31 @@ package Alire.Solver is -------------- type Age_Policies is (Oldest, Newest); - -- When looking for releases within a crate, which one to try first. - - type Completeness_Policies is - (First_Complete, - -- Stop after finding the first complete solution. No incomplete - -- solutions will be attempted. Other complete solutions may exist - -- that are globally "newer". - - All_Complete, - -- Only attempt to find complete solutions; the first unsatisfiable - -- dependency will result in abandoning that search branch. All - -- complete solutions will be found, and the best one according - -- to Solutions.Is_Better will be returned. - - Some_Incomplete, - -- Explores a reasonable subset of incomplete solutions: unknown crates, - -- crates with no satisfying releases, crates with externals can appear - -- as missing in the solution. - - All_Incomplete - -- All crates may appear as missing, even those that have satisfying - -- releases. All possible solutions and incomplete subsets are - -- eventually explored. - - ); - -- Allow the solver to further explore incomplete solution space. Each - -- value takes more time than the precedent one. All_Incomplete can take - -- a veeery long time when many crates/releases must be considered. TODO: - -- All these policies can go away once we move from a recursive solver to - -- a non-recursive priority-based one. + -- When looking for releases within a crate, which one to try first. The + -- usual is to look for newest packages, as these may include bugfixes; + -- but to avoid malicious updates some advocate the opposite strategy + -- (e.g. Google, where every update should be forced). type Detection_Policies is (Detect, Dont_Detect); -- * Detect: externals will be detected and added to the index once needed. -- * Dont_Detect: externals will remain undetected (faster). type Hinting_Policies is (Hint, Fail); - -- * Hint: any crate with externals, detected or not, will as last resort - -- provide a hint. + -- * Hint: any crate with externals or known to exist, detected or not, + -- will as last resort provide a hint. -- * Fail: fail for any unsatisfiable crate. If Detect, externally detected -- releases will be used normally; otherwise a crate with only externals -- will always cause failure. - type Timeout_Policies is - (Ask, -- Normal interaction with user - Stop, -- Abort at first timeout - Continue, -- Never ask and continue searching - Continue_While_Complete_Then_Stop - -- If there are complete solutions unexplored, continue searching. - -- Once complete are exhausted, the timeout timer will be reset and the - -- policy downgraded to Stop. This is intended to abort as soon as we - -- know there aren't complete solutions, but also to be able to provide - -- a decent incomplete solution so the problem can be diagnosed. + type Stopping_Policies is + (Continue, + -- Keep searching until finding the best complete solution or "best" + -- incomplete one, no matter how long it takes. + Ask, + -- Normal user interaction; not that we may ask before we are sure no + -- complete solutions exist (this will be informed to the user). + Stop + -- Stop on first timeout with the best solution found yet ); subtype Pin_Map is User_Pins.Maps.Map; @@ -124,37 +101,25 @@ package Alire.Solver is type Query_Options is record Age : Age_Policies := Newest; - Completeness : Completeness_Policies := First_Complete; - Exhaustive : Boolean := True; - -- When Exhaustive, Completeness is progressively downgraded. Otherwise - -- only the given Completeness is used. + Stopping : Stopping_Policies := Ask; Detecting : Detection_Policies := Detect; Hinting : Hinting_Policies := Hint; - On_Timeout : Timeout_Policies := Ask; Timeout : Duration := 5.0; -- Time until reporting problems finding a complete solution Timeout_More : Duration := 10.0; -- Extra period if the user wants to keep looking - - Elapsed : Duration := 0.0; - -- Extra elapsed time that has been already used in a previous search - -- configuration. No real use case for the user to modify it, but this - -- allows avoiding a big-ish refactoring that isn't worth the trouble. end record; Default_Options : constant Query_Options := (others => <>); - -- A reasonable combo that will return the first complete solution found, - -- or otherwise consider a subset of incomplete solutions. + -- Default options is to ask on timeout -- See child package Predefined_Options for more. function Resolve (Dep : Dependencies.Dependency; - Options : Query_Options := - (On_Timeout => Continue_While_Complete_Then_Stop, - others => <>)) + Options : Query_Options := Default_Options) return Solution; -- For when we only know the root crate without a precise version and want -- either a complete solution or a reasonable idea of what's preventing it. @@ -177,4 +142,78 @@ package Alire.Solver is return Boolean; -- Simplified call to Resolve, discarding result +private + + type State_Id is mod 2 ** 32 - 1; + + Current_Id : State_Id := 0; + + function Next_Id return State_Id; + + type Search_State is tagged record + Id : State_Id := Next_Id; + + Parent : State_Id := 0; + + Downgrade : Natural := 0; + -- A downgrade is the use of a release whose version is below the newest + -- one known for the required dependency (or viceversa when oldest + -- releases are requested). + + Seen : Dependencies.Containers.Set; + -- Any dependency already seen needs not to be explored, as it has been + -- done at some point upwards the search tree. + + Expanded, + -- Releases expanded to get new dependencies, in vector form just for + -- simplicity of imaging. This is currently informative, not used for + -- anything but debug during the search. + + Target, + -- Next subtree to consider + + Remaining : Types.Platform_Dependencies; + -- Nodes pending to be considered + + Solution : Alire.Solutions.Solution; + -- Partial or complete solution that stores releases + -- and dependencies processed up to now + end record; + + function Downgrading (This : access Search_State; + Downgrades : Natural) + return access Search_State; + -- Adds to the downgrades + + function Seeing (This : access Search_State; + Deps : Dependencies.Dependency) + return access Search_State; + -- Appends to Seen + + function Expanding (This : access Search_State; + Rel : Releases.Release) + return access Search_State; + -- Appends to Expanded + + function Expanding (This : access Search_State; + Rel : Conditional.Dependencies) + return access Search_State + with Pre => Rel.Is_Empty or else Rel.Is_Value; + -- Used simply for convenience when adding a broken link without release + + function Targeting (This : access Search_State; + Dep : Conditional.Dependencies) + return access Search_State; + -- Replaces Target + + function With_More (This : access Search_State; + Deps : Conditional.Dependencies) + return access Search_State; + -- Replaces the Remaining dependencies + + function Solved (This : access Search_State; + As : Solutions.Solution) + return access Search_State; + -- Replaces Solution + end Alire.Solver; diff --git a/src/alire/alire-utils-comparisons.ads b/src/alire/alire-utils-comparisons.ads new file mode 100644 index 000000000..7775acf26 --- /dev/null +++ b/src/alire/alire-utils-comparisons.ads @@ -0,0 +1,50 @@ +package Alire.Utils.Comparisons with Preelaborate is + + type Result is (Left, Equal, Right); + + type Bool_Result is (Left, Right, None, Both); + + ------------- + -- Compare -- + ------------- + + generic + type Comparable (<>) is limited private; + with function "<" (L, R : Comparable) return Boolean is <>; + function Compare (L, R : Comparable) return Result + with Post => Compare'Result = + (if L < R + then Left + else (if R < L + then Right + else Equal)); + + --------------- + -- Which_One -- + --------------- + + function Which_One (L, R : Boolean) return Bool_Result + is (if L and then not R then + Left + elsif R and then not L then + Right + elsif L then + Both + else + None); + +private + + ------------- + -- Compare -- + ------------- + + function Compare (L, R : Comparable) return Result + is (if L < R then + Left + elsif R < L then + Right + else + Equal); + +end Alire.Utils.Comparisons; diff --git a/src/alire/alire.ads b/src/alire/alire.ads index 2bccc8017..e9f7e124f 100644 --- a/src/alire/alire.ads +++ b/src/alire/alire.ads @@ -312,6 +312,7 @@ package Alire with Preelaborate is GNAT_Crate : constant Crate_Name; GNAT_External_Crate : constant Crate_Name; + GNAT_Native_Crate : constant Crate_Name; GPRbuild_Crate : constant Crate_Name; private @@ -358,6 +359,9 @@ private GNAT_External_Crate : constant Crate_Name := (Len => 13, Name => "gnat_external"); + GNAT_Native_Crate : constant Crate_Name := + (Len => 11, Name => "gnat_native"); + function U (S : Wide_Wide_String; Output_BOM : Boolean := False) return Ada.Strings.UTF_Encoding.UTF_8_String diff --git a/src/alr/alr-commands-search.adb b/src/alr/alr-commands-search.adb index 61f6feee2..ed6485f38 100644 --- a/src/alr/alr-commands-search.adb +++ b/src/alr/alr-commands-search.adb @@ -55,9 +55,9 @@ package body Alr.Commands.Search is (R.Dependencies (Platform.Properties), Platform.Properties, Alire.Solutions.Empty_Valid_Solution, - Options => (Age => Query_Policy, - On_Timeout => Solver.Stop, - others => <>)) + Options => (Age => Query_Policy, + Stopping => Solver.Stop, + others => <>)) then " " else Flag_Unsolv))); Tab.Append (TTY.Version (Semantic_Versioning.Image (R.Version))); diff --git a/testsuite/tests/solver/compiler-selected/test.py b/testsuite/tests/solver/compiler-selected/test.py index 70a10ccf4..31a179b26 100644 --- a/testsuite/tests/solver/compiler-selected/test.py +++ b/testsuite/tests/solver/compiler-selected/test.py @@ -11,6 +11,11 @@ # Select the default preferred compiler, which is the native packaged one run_alr("toolchain", "--select") +# Verify expected compiler is selected +p = run_alr("toolchain") +assert "gnat_native 8888.0.0 Default" in p.out, \ + f"Unexpected compiler selected: {p.out}" + # Init a crate depending on gnat init_local_crate("xxx") diff --git a/testsuite/tests/solver/forbids/test.py b/testsuite/tests/solver/forbids/test.py index c5d0c17a4..5b1fc4227 100644 --- a/testsuite/tests/solver/forbids/test.py +++ b/testsuite/tests/solver/forbids/test.py @@ -20,7 +20,7 @@ alr_with("crate_conflict") alr_with("crate_lone") match_solution("crate_(conflict|lone)=.* \(origin:.*\)") # has origin: solved -match_solution("crate_(conflict|lone)\* \(direct,missed:skipped\)") +match_solution("crate_(conflict|lone)\* \(direct,missed:(conflict|skipped)\)") # Because of load/solving details, we do not know which of the two crates is # going to be missed/accepted in the solution, so we check there is one of each @@ -28,6 +28,6 @@ alr_with("crate_conflict") alr_with("crate_virtual") match_solution("crate_(conflict|virtual)=.* \(origin:.*\)") -match_solution("crate_(conflict|virtual)\* \(direct,missed:skipped\)") +match_solution("crate_(conflict|virtual)\* \(direct,missed:(conflict|skipped)\)") print('SUCCESS')