From 12d781c50b244377ba366849498da41d74ed54ed Mon Sep 17 00:00:00 2001 From: Sarah Date: Mon, 18 Mar 2019 11:43:19 -0400 Subject: [PATCH] Store traces in a tree form rather than a list so span can be calculated. --- src/Development/Shake/Internal/Core/Action.hs | 14 +++- src/Development/Shake/Internal/Core/Build.hs | 2 +- src/Development/Shake/Internal/Core/Run.hs | 17 ++++- src/Development/Shake/Internal/Core/Types.hs | 56 ++++++++++++--- src/Development/Shake/Internal/Profile.hs | 68 +++++++++++++++---- 5 files changed, 129 insertions(+), 28 deletions(-) diff --git a/src/Development/Shake/Internal/Core/Action.hs b/src/Development/Shake/Internal/Core/Action.hs index 4d258a3be..8d5750d44 100644 --- a/src/Development/Shake/Internal/Core/Action.hs +++ b/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 diff --git a/src/Development/Shake/Internal/Core/Build.hs b/src/Development/Shake/Internal/Core/Build.hs index e2776c23c..9071ac48a 100644 --- a/src/Development/Shake/Internal/Core/Build.hs +++ b/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) diff --git a/src/Development/Shake/Internal/Core/Run.hs b/src/Development/Shake/Internal/Core/Run.hs index 9746b98e8..a1fd444ed 100644 --- a/src/Development/Shake/Internal/Core/Run.hs +++ b/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 diff --git a/src/Development/Shake/Internal/Core/Types.hs b/src/Development/Shake/Internal/Core/Types.hs index cbde0458f..ed3f954dd 100755 --- a/src/Development/Shake/Internal/Core/Types.hs +++ b/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 } diff --git a/src/Development/Shake/Internal/Profile.hs b/src/Development/Shake/Internal/Profile.hs index b2fe226d7..d729db2e4 100644 --- a/src/Development/Shake/Internal/Profile.hs +++ b/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,24 +148,25 @@ 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 @@ -135,11 +174,10 @@ generateHTML xs = do 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