Improve hspace shrinking strategy

In tired allocation, hspace shrinks that resource of the instance
next, that causes failure on most nodes. While, this is not a bad
strategy in general, it can lead hspace into a dead end if for a large
number of nodes a particular resource blocks any further allocation of
policy compliant instances. So we improve the heuristics in that it
chooses to shrink such a resource next where by shrinking only this
resource a valid allocation can be made, if such a resource
exists. This improves the results in some cases, while still keeping
the computational complexity of the algorithm low.

Signed-off-by: Klaus Aehlig <aehlig@google.com>
Reviewed-by: Michele Tartara <mtartara@google.com>

diff --git a/src/Ganeti/HTools/Cluster.hs b/src/Ganeti/HTools/Cluster.hs
index 7b4a67c..e598d0d 100644 (file)
--- a/src/Ganeti/HTools/Cluster.hs
+++ b/src/Ganeti/HTools/Cluster.hs
@@ -78,7 +78,7 @@ module Ganeti.HTools.Cluster
 
 import qualified Data.IntSet as IntSet
 import Data.List
-import Data.Maybe (fromJust, isNothing)
+import Data.Maybe (fromJust, fromMaybe, isJust, isNothing)
 import Data.Ord (comparing)
 import Text.Printf (printf)
 
@@ -1279,6 +1279,13 @@ iterateAlloc nl il limit newinst allocnodes ixes cstats =
                       newlimit newinst allocnodes (xi:ixes)
                       (totalResources xnl:cstats)
 
+-- | Predicate whether shrinking a single resource can lead to a valid
+-- allocation.
+sufficesShrinking :: (Instance.Instance -> AllocSolution) -> Instance.Instance
+                     -> FailMode  -> Bool
+sufficesShrinking allocFn inst fm = any isJust . map (asSolution . allocFn) $
+                                    iterateOk (`Instance.shrinkByType` fm) inst
+
 -- | Tiered allocation method.
 --
 -- This places instances on the cluster, and decreases the spec until
@@ -1294,10 +1301,14 @@ tieredAlloc nl il limit newinst allocnodes ixes cstats =
           (stop, newlimit) = case limit of
                                Nothing -> (False, Nothing)
                                Just n -> (n <= ixes_cnt,
-                                            Just (n - ixes_cnt)) in
-      if stop then newsol else
-          case Instance.shrinkByType newinst . fst . last $
-               sortBy (comparing snd) errs of
+                                            Just (n - ixes_cnt))
+          sortedErrs = map fst $ sortBy (comparing snd) errs
+          suffShrink = sufficesShrinking (fromMaybe emptyAllocSolution
+                                          . flip (tryAlloc nl' il') allocnodes)
+                       newinst
+      in if stop then newsol else
+          case Instance.shrinkByType newinst . last $
+               sortedErrs ++ filter suffShrink sortedErrs of
             Bad _ -> newsol
             Ok newinst' -> tieredAlloc nl' il' newlimit
                            newinst' allocnodes ixes' cstats'