Implement first version of tiered allocations

This patch adds the first version of tiered allocations where we
decrease instance specs on allocation failure and retry the allocation.
The output is not yet stable and the output changes are not documented
(yet).

diff --git a/hspace.hs b/hspace.hs
index b2439dc..f34f3d1 100644 (file)
--- a/hspace.hs
+++ b/hspace.hs
@@ -68,7 +68,11 @@ options =
     , oShowHelp
     ]
 
     , oShowHelp
     ]
 

-data Phase = PInitial | PFinal
+-- | The allocation phase we're in (initial, after tiered allocs, or
+-- after regular allocation).
+data Phase = PInitial
+           | PFinal
+           | PTiered

 
 statsData :: [(String, Cluster.CStats -> String)]
 statsData = [ ("SCORE", printf "%.8f" . Cluster.csScore)
 
 statsData :: [(String, Cluster.CStats -> String)]
 statsData = [ ("SCORE", printf "%.8f" . Cluster.csScore)

@@ -131,6 +135,23 @@ iterateDepth nl il newinst nreq ixes =
                  Just (_, (xnl, xi, _)) ->
                      iterateDepth xnl il newinst nreq $! (xi:ixes)
 
                  Just (_, (xnl, xi, _)) ->
                      iterateDepth xnl il newinst nreq $! (xi:ixes)
 

+tieredAlloc :: Node.List
+            -> Instance.List
+            -> Instance.Instance
+            -> Int
+            -> [Instance.Instance]
+            -> Result (FailStats, Node.List, [Instance.Instance])
+tieredAlloc nl il newinst nreq ixes =
+    case iterateDepth nl il newinst nreq ixes of
+      Bad s -> Bad s
+      Ok (errs, nl', ixes') ->
+          case Instance.shrinkByType newinst . fst . last $
+               sortBy (compare `on` snd) errs of
+            Bad _ -> Ok (errs, nl', ixes')
+            Ok newinst' ->
+                tieredAlloc nl' il newinst' nreq ixes'
+
+

 -- | Function to print stats for a given phase
 printStats :: Phase -> Cluster.CStats -> [(String, String)]
 printStats ph cs =
 -- | Function to print stats for a given phase
 printStats :: Phase -> Cluster.CStats -> [(String, String)]
 printStats ph cs =

@@ -138,6 +159,7 @@ printStats ph cs =
   where kind = case ph of
                  PInitial -> "INI"
                  PFinal -> "FIN"
   where kind = case ph of
                  PInitial -> "INI"
                  PFinal -> "FIN"

+                 PTiered -> "TRL"

 
 -- | Print final stats and related metrics
 printResults :: Node.List -> Int -> Int -> [(FailMode, Int)] -> IO ()
 
 -- | Print final stats and related metrics
 printResults :: Node.List -> Int -> Int -> [(FailMode, Int)] -> IO ()

@@ -251,15 +273,44 @@ main = do
          printResults nl num_instances 0 [(FailN1, 1)]
          exitWith ExitSuccess
 
          printResults nl num_instances 0 [(FailN1, 1)]
          exitWith ExitSuccess
 

-  let reqinst = Instance.create "new" (rspecMem ispec) (rspecDsk ispec)
-                (rspecCpu ispec) "ADMIN_down" (-1) (-1)
+  -- utility functions
+  let iofspec spx = Instance.create "new" (rspecMem spx) (rspecDsk spx)
+                    (rspecCpu spx) "ADMIN_down" (-1) (-1)
+      exitifbad val = (case val of
+                         Bad s -> do
+                           hPrintf stderr "Failure: %s\n" s
+                           exitWith $ ExitFailure 1
+                         Ok x -> return x)
+
+
+  let reqinst = iofspec ispec
+
+  -- Run the tiered allocation, if enabled
+
+  (case optTieredSpec opts of
+     Nothing -> return ()
+     Just tspec -> do
+       let tresu = tieredAlloc nl il (iofspec tspec) req_nodes []
+       (_, trl_nl, trl_ixes) <- exitifbad tresu
+       let fin_trl_ixes = reverse trl_ixes
+
+       when (verbose > 1) $ do
+         hPutStrLn stderr "Tiered allocation map"
+         hPutStr stderr . unlines . map ((:) ' ' .  intercalate " ") $
+                 formatTable (map (printInstance trl_nl) fin_trl_ixes)
+                                 [False, False, False, True, True, True]
+       when (optShowNodes opts) $ do
+         hPutStrLn stderr ""
+         hPutStrLn stderr "Tiered allocation status:"
+         hPutStrLn stderr $ Cluster.printNodes trl_nl
+
+         printKeys $ printStats PTiered (Cluster.totalResources trl_nl))
+
+  -- Run the standard (avg-mode) allocation

 
   let result = iterateDepth nl il reqinst req_nodes []
 
   let result = iterateDepth nl il reqinst req_nodes []

-  (ereason, fin_nl, ixes) <- (case result of
-                                Bad s -> do
-                                  hPrintf stderr "Failure: %s\n" s
-                                  exitWith $ ExitFailure 1
-                                Ok x -> return x)
+  (ereason, fin_nl, ixes) <- exitifbad result
+

   let allocs = length ixes
       fin_ixes = reverse ixes
       sreason = reverse $ sortBy (compare `on` snd) ereason
   let allocs = length ixes
       fin_ixes = reverse ixes
       sreason = reverse $ sortBy (compare `on` snd) ereason