Store traces in a tree form rather than a list so span can be calcula…

src/Development/Shake/Internal/Core/Action.hs

@@ -243,9 +243,21 @@ traced msg act = do
     stop <- liftIO globalTimestamp
     let trace = newTrace msg start stop
     liftIO $ evaluate $ rnf trace
-    Action $ modifyRW $ \s -> s{localTraces = trace : localTraces s}
+    Action $ modifyRW $ \s -> s{localTraces = mergeTraceTForest trace $ localTraces s}
     return res
 
+mergeTraceTForest :: Trace -> TForest -> TForest
+mergeTraceTForest t tf =
+  let f (TTree d cs) t2 = TTree d $ if null cs then
+                                      [t2] else
+                                      map (\t3 -> f t3 t2) cs
+      f (TLeaf d) t2 = TTree d [t2]
+      n = TLeaf t
+      roots = tRoots tf in
+    TForest { tRoots = if null roots
+                       then [n]
+                       else map (\t2 -> f t2 n) roots
+            , tracesList = t:(tracesList tf) }
 
 ---------------------------------------------------------------------
 -- TRACKING

src/Development/Shake/Internal/Core/Build.hs

@@ -212,7 +212,7 @@ runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode continue
                         ,built = globalStep
                         ,depends = nubDepends $ reverse localDepends
                         ,execution = doubleToFloat $ dur - localDiscount
-                        ,traces = reverse localTraces}
+                        ,traces = localTraces}
             where
                 mkResult value store = (value, if globalOneShot then BS.empty else store)
 

src/Development/Shake/Internal/Core/Run.hs

@@ -337,7 +337,7 @@ incrementStep db = runLocked db $ do
     return step
 
 toStepResult :: Step -> Result (Value, BS_Store)
-toStepResult i = Result (newValue i, runBuilder $ putEx i) i i [] 0 []
+toStepResult i = Result (newValue i, runBuilder $ putEx i) i i [] 0 $ TForest [] []
 
 fromStepResult :: Result BS_Store -> Step
 fromStepResult = getEx . result
@@ -353,10 +353,23 @@ recordRoot step locals (doubleToFloat -> end) db = runLocked db $ do
             ,built = step
             ,depends = nubDepends $ reverse $ localDepends local
             ,execution = 0
-            ,traces = reverse $ Trace BS.empty end end : localTraces local}
+            ,traces = mergeTraceTForest (Trace BS.empty end end) (localTraces local)}
     setMem db rootId rootKey $ Ready rootRes
     liftIO $ setDisk db rootId rootKey $ Loaded $ fmap snd rootRes
 
+mergeTraceTForest :: Trace -> TForest -> TForest
+mergeTraceTForest t tf =
+  let f (TTree d cs) t2 = TTree d $ if null cs then
+                                      [t2] else
+                                      map (\t3 -> f t3 t2) cs
+      f (TLeaf d) t2 = TTree d [t2]
+      n = TLeaf t
+      roots = tRoots tf in
+    TForest { tRoots = if null roots
+                       then [n]
+                       else map (\t2 -> f t2 n) roots
+            , tracesList = t:(tracesList tf) }
+
 
 loadSharedCloud :: DatabasePoly k v -> ShakeOptions -> Map.HashMap TypeRep BuiltinRule -> IO (Maybe Shared, Maybe Cloud)
 loadSharedCloud var opts owitness = do

src/Development/Shake/Internal/Core/Types.hs

@@ -12,7 +12,8 @@ module Development.Shake.Internal.Core.Types(
     getResult, exceptionStack, statusType, addStack, addCallStack,
     incStep, newTrace, nubDepends, emptyStack, topStack, showTopStack,
     stepKey, StepKey(..),
-    rootKey, Root(..)
+    rootKey, Root(..),
+    TForest(..), TTree(..)
     ) where
 
 import Control.Monad.IO.Class
@@ -123,7 +124,6 @@ newtype StepKey = StepKey ()
 stepKey :: Key
 stepKey = newKey $ StepKey ()
 
-
 -- To make sure profiling has a complete view of what was demanded and all top-level 'action'
 -- things we fake up a Root node representing everything that was demanded
 newtype Root = Root () deriving (Eq,Typeable,Hashable,Binary,BinaryEx,NFData)
@@ -183,9 +183,28 @@ data Trace = Trace
     }
     deriving Show
 
+data TTree = TTree
+  {tData :: Trace
+  ,tChildren :: [TTree]}
+  | TLeaf
+    {tData :: Trace}
+  deriving Show
+
+data TForest = TForest
+  {tRoots :: [TTree]
+  , tracesList :: [Trace] -- tracesList is stored in reverse. 
+  } deriving Show
+
 instance NFData Trace where
     rnf x = x `seq` () -- all strict atomic fields
 
+instance NFData TForest where
+  rnf (TForest rs ts) = rnf rs `seq` rnf ts
+
+instance NFData TTree where
+  rnf (TLeaf t) = rnf t
+  rnf (TTree t ts) = rnf t `seq` rnf ts
+
 instance BinaryEx Trace where
     putEx (Trace a b c) = putEx b <> putEx c <> putEx a
     getEx x | (b,c,a) <- binarySplit2 x = Trace a b c
@@ -194,6 +213,19 @@ instance BinaryEx [Trace] where
     putEx = putExList . map putEx
     getEx = map getEx . getExList
 
+instance BinaryEx TForest where
+  putEx (TForest ls ls2) = putExList $ (putExList (map putEx ls2)):(map putEx ls)
+  getEx x = let y = getExList x in
+              let ls2 = map getEx $ getExList $ head y in
+                TForest (map getEx $ tail y) ls2
+
+instance BinaryEx TTree where
+  putEx (TTree t ls) = putExList $ (putEx t):(map putEx ls)
+  putEx (TLeaf t) = putExList [putEx t]
+  getEx x = case getExList x of
+              [t] -> TLeaf $ getEx t
+              t:ls -> TTree (getEx t) (map getEx ls)
+
 newTrace :: String -> Seconds -> Seconds -> Trace
 newTrace msg start stop = Trace (BS.pack msg) (doubleToFloat start) (doubleToFloat stop)
 
@@ -232,7 +264,7 @@ data Result a = Result
     ,changed :: {-# UNPACK #-} !Step -- ^ the step for deciding if it's valid
     ,depends :: [Depends] -- ^ dependencies (don't run them early)
     ,execution :: {-# UNPACK #-} !Float -- ^ how long it took when it was last run (seconds)
-    ,traces :: [Trace] -- ^ a trace of the expensive operations (start/end in seconds since beginning of run)
+    ,traces :: TForest -- ^ a trace of the expensive operations (start/end in seconds since beginning of run)
     } deriving (Show,Functor)
 
 instance NFData a => NFData (Result a) where
@@ -416,7 +448,7 @@ data Local = Local
     -- mutable local variables
     ,localDepends :: [Depends] -- ^ Dependencies, built up in reverse
     ,localDiscount :: !Seconds -- ^ Time spend building dependencies (may be negative for parallel)
-    ,localTraces :: [Trace] -- ^ Traces, built in reverse
+    ,localTraces :: TForest -- ^ Traces, built in reverse
     ,localTrackAllows :: [Key -> Bool] -- ^ Things that are allowed to be used
     ,localTrackUsed :: [Key] -- ^ Things that have been used
     ,localProduces :: [(Bool, FilePath)] -- ^ Things this rule produces, True to check them
@@ -427,7 +459,7 @@ addDiscount :: Seconds -> Local -> Local
 addDiscount s l = l{localDiscount = s + localDiscount l}
 
 newLocal :: Stack -> Verbosity -> Local
-newLocal stack verb = Local stack (Ver 0) verb Nothing [] 0 [] [] [] [] True
+newLocal stack verb = Local stack (Ver 0) verb Nothing [] 0 (TForest [] []) [] [] [] True
 
 -- Clear all the local mutable variables
 localClearMutable :: Local -> Local
@@ -447,7 +479,7 @@ localMergeMutable root xs = Local
     -- note that a lot of the lists are stored in reverse, assume root happened first
     ,localDepends = mergeDependsRev (map localDepends xs) ++ localDepends root
     ,localDiscount = sum $ map localDiscount $ root : xs
-    ,localTraces = mergeTracesRev (map localTraces xs) ++ localTraces root
+    ,localTraces = mergeTForests (localTraces root) (map localTraces xs)
     ,localTrackAllows = localTrackAllows root ++ concatMap localTrackAllows xs
     ,localTrackUsed = localTrackUsed root ++ concatMap localTrackUsed xs
     ,localProduces = concatMap localProduces xs ++ localProduces root
@@ -463,6 +495,12 @@ mergeDependsRev = reverse . f . map reverse
         f xs = mconcat now : f next
             where (now, next) = unzip $ mapMaybe uncons xs
 
-mergeTracesRev :: [[Trace]] -> [Trace]
--- might want to resort them?
-mergeTracesRev = concat
+mergeTForests :: TForest -> [TForest] -> TForest
+mergeTForests (TForest rs ls) fs =
+  let f (TLeaf d) xs = TTree d xs
+      f (TTree d cs) xs = TTree d $ map (\x -> f x xs) cs
+      ts = concatMap tRoots fs in
+    TForest { tRoots = if null rs then
+                         ts else
+                         map (\t -> f t ts) rs
+            , tracesList = (concatMap tracesList fs) ++ ls }

src/Development/Shake/Internal/Profile.hs

@@ -81,19 +81,57 @@ toReport db = do
             ,prfChanged = fromStep changed
             ,prfDepends = filter (not . null) $ map (mapMaybe (`Map.lookup` ids) . fromDepends) depends
             ,prfExecution = floatToDouble execution
-            ,prfTraces = map fromTrace $ sortOn traceStart traces
+            ,prfTraces = fromTForest traces
             }
             where fromStep i = fromJust $ Map.lookup i steps
-                  fromTrace (Trace a b c) = ProfileTrace (BS.unpack a) (floatToDouble b) (floatToDouble c)
     return [maybe (throwImpure $ errorInternal "toReport") f $ Map.lookup i status | i <- order]
 
+fromTForest :: TForest -> PtForest
+fromTForest TForest{..} =
+  let fromTTree TLeaf{..} = PtLeaf $ fromTrace tData
+      fromTTree TTree{..} = PtTree (fromTrace tData) (map fromTTree tChildren)
+      fromTrace (Trace a b c) = ProfileTrace (BS.unpack a) (floatToDouble b) (floatToDouble c) in
+    PtForest (map fromTTree tRoots) $ reverse (map fromTrace tracesList)
+
+data PtForest = PtForest {ptRoots :: [PtTree]
+                         , prfTracesList :: [ProfileTrace]}
+
+data PtTree =
+  PtTree {ptData :: ProfileTrace, ptChildren :: [PtTree]}
+  | PtLeaf {ptData :: ProfileTrace}
 
 data ProfileEntry = ProfileEntry
-    {prfName :: String, prfBuilt :: Int, prfChanged :: Int, prfDepends :: [[Int]], prfExecution :: Double, prfTraces :: [ProfileTrace]}
+    {prfName :: String, prfBuilt :: Int, prfChanged :: Int, prfDepends :: [[Int]], prfExecution :: Double, prfTraces :: PtForest}
 data ProfileTrace = ProfileTrace
     {prfCommand :: String, prfStart :: Double, prfStop :: Double}
 prfTime ProfileTrace{..} = prfStop - prfStart
 
+work :: [ProfileEntry] -> Double
+work xs = sum $ map prfExecution xs
+
+spanOfPtForest :: PtForest -> Double
+spanOfPtForest f =
+  let spanOfPtTree (PtLeaf d) = prfTime d
+      spanOfPtTree (PtTree d ls) = prfTime d + (foldl (\m x -> max m $ spanOfPtTree x) 0 ls) in
+    foldl (\m x -> max m $ spanOfPtTree x) 0 $ ptRoots f
+
+-- spanOf a profileentry is span of deps + span of traces
+spanOfPE :: ProfileEntry -> [ProfileEntry] -> Double
+spanOfPE x xs = let f deps = foldl (\s ls -> s + foldl (\m i -> max m $ spanOfPE (xs!!i) xs) 0 ls)
+                             0 deps in
+                  (f $ prfDepends x) + (spanOfPtForest $ prfTraces x)
+
+spanInternal :: [ProfileEntry] -> Double
+spanInternal xs = let roots ys =
+                        let deps = concatMap (concat . prfDepends) ys in
+                          foldl (\ls i -> if elem i deps then
+                                            ls else
+                                            (ys!!i):ls)
+                          [] [0..((length ys) - 1)] in
+                    foldl (\m x -> max m $ spanOfPE x xs) 0 $ roots xs
+
+workSpan :: [ProfileEntry] -> (Double, Double)
+workSpan xs = (work xs, spanInternal xs)
 
 -- | Generates an report given some build system profiling data.
 writeProfile :: FilePath -> Database -> IO ()
@@ -110,36 +148,36 @@ writeProfileInternal out xs
     --       Verified with similar "type foo > bar" commands taking similar time.
     | otherwise = LBS.writeFile out =<< generateHTML xs
 
-
 generateSummary :: [ProfileEntry] -> [String]
 generateSummary xs =
     ["* This database has tracked " ++ show (maximum (0 : map prfChanged xs) + 1) ++ " runs."
     ,let f = show . length in "* There are " ++ f xs ++ " rules (" ++ f ls ++ " rebuilt in the last run)."
-    ,let f = show . sum . map (length . prfTraces) in "* Building required " ++ f xs ++ " traced commands (" ++ f ls ++ " in the last run)."
+    ,let f = show . sum . map (\pe -> (length . prfTracesList) $ prfTraces pe) in "* Building required " ++ f xs ++ " traced commands (" ++ f ls ++ " in the last run)."
     ,"* The total (unparallelised) time is " ++ showDuration (sum $ map prfExecution xs) ++
-        " of which " ++ showDuration (sum $ map prfTime $ concatMap prfTraces xs) ++ " is traced commands."
+        " of which " ++ showDuration (sum $ map prfTime $ concatMap (prfTracesList . prfTraces) xs) ++ " is traced commands."
     ,let f xs = if null xs then "0s" else (\(a,b) -> showDuration a ++ " (" ++ b ++ ")") $ maximumBy' (compare `on` fst) xs in
         "* The longest rule takes " ++ f (map (prfExecution &&& prfName) xs) ++
-        ", and the longest traced command takes " ++ f (map (prfTime &&& prfCommand) $ concatMap prfTraces xs) ++ "."
-    ,let sumLast = sum $ map prfTime $ concatMap prfTraces ls
-         maxStop = maximum $ 0 : map prfStop (concatMap prfTraces ls) in
+        ", and the longest traced command takes " ++ f (map (prfTime &&& prfCommand) $ concatMap (prfTracesList . prfTraces) xs) ++ "."
+    ,let sumLast = sum $ map prfTime $ concatMap (prfTracesList . prfTraces) ls
+         maxStop = maximum $ 0 : map prfStop (concatMap (prfTracesList . prfTraces) ls) in
         "* Last run gave an average parallelism of " ++ showDP 2 (if maxStop == 0 then 0 else sumLast / maxStop) ++
         " times over " ++ showDuration maxStop ++ "."
+    ,"* Span is " ++ show span
+    ,"* Work is " ++ show work
     ]
     where ls = filter ((==) 0 . prfBuilt) xs
-
+          (work, span) = workSpan xs
 
 generateHTML :: [ProfileEntry] -> IO LBS.ByteString
 generateHTML xs = do
     report <- readDataFileHTML "profile.html"
     let f "data/profile-data.js" = return $ LBS.pack $ "var profile =\n" ++ generateJSON xs
     runTemplate f report
 
-
 generateTrace :: [ProfileEntry] -> String
 generateTrace xs = jsonListLines $
-    showEntries 0 [y{prfCommand=prfName x} | x <- xs, y <- prfTraces x] ++
-    showEntries 1 (concatMap prfTraces xs)
+    showEntries 0 [y{prfCommand=prfName x} | x <- xs, y <- prfTracesList $ prfTraces x] ++
+    showEntries 1 (concatMap (prfTracesList . prfTraces) xs)
     where
         showEntries pid xs = map (showEntry pid) $ snd $ mapAccumL alloc [] $ sortOn prfStart xs
 
@@ -162,8 +200,8 @@ generateJSON = jsonListLines . map showEntry
             ,showTime prfExecution
             ,show prfBuilt
             ,show prfChanged] ++
-            [show prfDepends | not (null prfDepends) || not (null prfTraces)] ++
-            [jsonList $ map showTrace prfTraces | not (null prfTraces)]
+            [show prfDepends | not (null prfDepends) || not (null $ prfTracesList prfTraces)] ++
+            [jsonList $ map showTrace $ prfTracesList prfTraces | not (null $ prfTracesList prfTraces)]
         showTrace ProfileTrace{..} = jsonList
             [show prfCommand, showTime prfStart, showTime prfStop]
         showTime x = if '.' `elem` y then dropWhileEnd (== '.') $ dropWhileEnd (== '0') y else y