diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,39 @@ +0.9.0 - 090810 +* switched to Int64 for representing costs +* added a Maybe layer to readProfile as well + +0.8.0 - 090802 +* introduced profile query class to provide some flexibility +* introduced the statistics module + +0.7.0 - 090731 +* threw out most of the network protocol, which was obsoleted by the + idea that the grapher is provided as a library instead of a remote + controlled application + +0.6.0 - 090729 +* added a Maybe layer to the return values of profiling functions + +0.5.0 - 090720 +* added the ability to stop an asynchronous loading operation + +0.4.0 - 090718 +* added asynchronous loading + +0.3.0 - 090705 +* added interface for remote profiling, moved in networking code from + the grapher and the relay test apps +* modified stopper action to acknowledge the end of profiling by + invoking the callback with SinkStop +* hid internals and tests + +0.2.0 - 090624 +* network protocol implemented (un/marshalling functions) + +0.1.0 - 090613 +* added interface to specify profiling parameters +* added stopper action that terminates the reader thread in a clean way +* switched to bytestrings + +0.0.0 - 090528 +* basic functionality: profileCallback, profile, readProfile, and querying diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2009, Patai Gergely +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Profiling/Heap/Network.hs b/Profiling/Heap/Network.hs new file mode 100644 --- /dev/null +++ b/Profiling/Heap/Network.hs @@ -0,0 +1,161 @@ +{-| This module provides functions to send and receive profiling +information over the network. Currently the messages can only encode +'SinkInput' data. -} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Profiling.Heap.Network + ( Message(..) + , sendMsg + , recvMsg + , readMsg + , writeMsg + , putStream + , getStream + ) where + +import Control.Applicative +import Control.Arrow +--import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.Int +import Data.Maybe +import Data.List +import Profiling.Heap.Types +import System.IO + +data Message = Stream SinkInput + +sStrSample = "str_sample" +sStrName = "str_name" +sStrStop = "str_stop" + +{-| Send a structured message over the network. Can also be used for +logging into a file. -} + +sendMsg :: Handle -> Message -> IO () +sendMsg hdl = hPutStrLn hdl . writeMsg + +{-| Receive a structured message over the network. Can also be used +for parsing from a file. -} + +recvMsg :: Handle -> IO (Maybe Message) +recvMsg hdl = readMsg <$> hGetLine hdl + +{-| Parse a message. -} + +readMsg :: String -> Maybe Message +readMsg = parseString messageParser + +{-| Serialise a message. -} + +writeMsg :: Message -> String +writeMsg = show + +{-| Convert from callback data to message. -} + +putStream :: SinkInput -> Message +putStream = Stream + +{-| Extract callback data from message, if applicable. -} + +getStream :: Message -> Maybe SinkInput +getStream (Stream dat) = Just dat +--getStream _ = Nothing + +instance Show Message where + showsPrec _ (Stream (SinkSample t ps)) = showString sStrSample . sepShows t . showPairs ps + showsPrec _ (Stream (SinkId ccid name)) = showString sStrName . sepShows ccid . sepStr (S.unpack name) + showsPrec _ (Stream SinkStop) = showString sStrStop + +sep = showChar '\t' +sepStr s = sep . showString s +sepShows x = sep . shows x + +showListMap g = foldr (\x f -> sep . g x . f) id +showPairs l = showListMap (\(x,y) -> shows x . sepShows y) l + +-- * A minimal and rather dumb applicative parser, uulib style + +-- pPref should really be a list of possible prefixes in order to be +-- able to implement the choice operator properly, but this simpler +-- version is perfectly fine for our purposes. +data MsgParser a = MP { pPref :: String, _pFun :: String -> Maybe (a,String) } + +instance Functor MsgParser where + fmap f (MP p g) = MP p ((fmap.fmap) (first f) g) + +instance Applicative MsgParser where + pure x = MP "" (Just . (,) x) + MP pf gf <*> MP px gx = MP pf $ \s -> do + (f,s') <- gf s + s'' <- stripPrefix px s' + (x,s''') <- gx s'' + return (f x,s''') + +-- Shady business here: going from bottom to top! +instance Alternative MsgParser where + empty = MP "" (const Nothing) + MP p1 g1 <|> MP p2 g2 = MP "" $ \s -> + (stripPrefix p2 s >>= g2) <|> (stripPrefix p1 s >>= g1) + +infixl 3 <||> + +-- Alternative with cut (can fail on parseable strings if either p1 or +-- p2 is the prefix of the other, but it prevents a space leak if they +-- aren't). Yay for past obsession with Prolog. +(<||>) :: MsgParser a -> MsgParser a -> MsgParser a +MP p1 g1 <||> MP p2 g2 = MP "" $ \s -> + case stripPrefix p2 s of + Just s' -> g2 s' + Nothing -> case stripPrefix p1 s of + Just s'' -> g1 s'' + Nothing -> Nothing + +pInt :: MsgParser Int +pInt = MP "" $ listToMaybe . reads + +pInt64 :: MsgParser Int64 +pInt64 = MP "" $ listToMaybe . reads + +pFrac :: MsgParser Double +pFrac = MP "" $ listToMaybe . reads + +--pKey :: MsgParser String +--pKey = MP "" $ \str -> +-- let (pre,post) = span (`elem` '_':['a'..'z']) str +-- in if null pre then Nothing else Just (pre,post) + +pChr :: Char -> MsgParser Char +pChr c = (pure c) { pPref = [c] } + +pParam :: MsgParser String +pParam = MP "" $ Just . span (>=' ') + +-- This can only be used at the end of a string, because: +-- * we assume one delimiter between items (and it can change...) +-- * the remainder is not preserved +pMany :: MsgParser a -> MsgParser [a] +pMany (MP p g) = MP "" $ \str -> + let rl s = case g =<< stripPrefix p s of + Nothing -> [] + Just (v,s') -> v : if null s' then [] else rl (tail s') + in Just (rl str,"") + +infixl 4 <=> +infixl 4 <-> + +(<=>) :: String -> a -> MsgParser a +s <=> v = (pure v) { pPref = s } + +(<->) :: MsgParser (a -> b) -> MsgParser a -> MsgParser b +p1 <-> p2 = p1 <* pChr '\t' <*> p2 + +parseString :: MsgParser a -> String -> Maybe a +parseString (MP p g) s = fst <$> (g =<< stripPrefix p s) + +messageParser :: MsgParser Message +messageParser = sStrSample <=> (\t smp -> Stream (SinkSample t smp)) <-> pFrac <-> pProfSample + <||> sStrName <=> (\ccid name -> Stream (SinkId ccid name)) <-> pInt <-> (S.pack <$> pParam) + <||> sStrStop <=> Stream SinkStop + where pProfSample = pMany ((,) <$> pInt <-> pInt64) diff --git a/Profiling/Heap/Process.hs b/Profiling/Heap/Process.hs new file mode 100644 --- /dev/null +++ b/Profiling/Heap/Process.hs @@ -0,0 +1,110 @@ +{-| This is a utility module to aid the construction of +'CreateProcess' structures with profiling parameters. -} + +module Profiling.Heap.Process + ( ProfParam(..) + , Breakdown(..) + , Restriction(..) + , processToProfile + ) where + +import System.Process +import Text.Printf + +{-| The possible types of parameters. -} +data ProfParam + -- | The type of breakdown. + = PPBreakdown Breakdown + -- | An additional filter on the runtime side. + | PPRestriction Restriction [String] + -- | Sampling interval in seconds. + | PPInterval Float + -- | Whether to include memory taken up by threads. + | PPIncludeThreads + -- | The maximum length of cost centre stack names. + | PPNameLength Int + -- | Retainer set size limit. + | PPRetainerLimit Int + +{-| The possible types of breakdowns. -} +data Breakdown + -- | Breakdown by cost centre stack (origin of the data). + = BCostCentreStack + -- | Breakdown by module (code responsible for the data). + | BModule + -- | Breakdown by closure description (constructor name or some + -- unique identifier). + | BDescription + -- | Breakdown by type (or an approximation if it is not known + -- exactly). + | BType + -- | Breakdown by retainer set (effectively the entities that hold + -- a direct reference to the data in question). + | BRetainer + -- | Breakdown by biography (phase of an object's lifetime). + | BBiography + +{-| The possible filters. Note that these are imposed by the runtime, +so we cannot override them on the application side. -} +data Restriction + -- | Show only closures with one of the given names on the top of + -- the cost centre stack. + = RCCStackTop + -- | Show only closures with one of the given names somewhere in + -- the cost centre stack. + | RCCStackAny + -- | Show only closures produced by one of the given modules. + | RModule + -- | Show only closures with a description that matches one of the + -- given names. + | RDescription + -- | Show only closures with one of the given types. + | RType + -- | Show only closures with retainer sets that contain at least + -- one cost centre stack with a given name on the top. + | RRetainer + -- | Show only closures with one of the specified biographies, + -- which must come from the set {lag, drag, void, use}. + | RBiography + +instance Show ProfParam where + showsPrec _ (PPBreakdown b) = showString "-h" . shows b + showsPrec _ (PPRestriction r ns) = showString "-h" . shows r . showsNames ns + showsPrec _ (PPInterval i) = showString "-i" . showString (printf "%.2f" i) + showsPrec _ (PPIncludeThreads) = showString "-xt" + showsPrec _ (PPNameLength l) = showString "-L" . shows l + showsPrec _ (PPRetainerLimit l) = showString "-R" . shows l + showList ps = foldr (\p s -> shows p . showChar ' ' . s) id ps + +instance Show Breakdown where + showsPrec _ BCostCentreStack = showChar 'c' + showsPrec _ BModule = showChar 'm' + showsPrec _ BDescription = showChar 'd' + showsPrec _ BType = showChar 'y' + showsPrec _ BRetainer = showChar 'r' + showsPrec _ BBiography = showChar 'b' + +instance Show Restriction where + showsPrec _ RCCStackTop = showChar 'c' + showsPrec _ RCCStackAny = showChar 'C' + showsPrec _ RModule = showChar 'm' + showsPrec _ RDescription = showChar 'd' + showsPrec _ RType = showChar 'y' + showsPrec _ RRetainer = showChar 'r' + showsPrec _ RBiography = showChar 'b' + +showsNames :: [String] -> String -> String +showsNames [] = id +showsNames [n] = showString n +showsNames (n:ns) = showString n . showChar ',' . showsNames ns + +{-| A helper function to create a 'CreateProcess' structure. -} +processToProfile :: FilePath -- ^ The executable to profile (relative paths start from the working directory). + -> Maybe FilePath -- ^ An optional working directory (inherited from the parent if not given). + -> String -- ^ The list of parameters to pass to the program. + -> [ProfParam] -- ^ Profiling parameters. + -> CreateProcess -- ^ The resulting structure. +processToProfile exec dir params profParams = (shell cmd) { cwd = dir } + where -- Note: this doesn't handle --RTS in the param string! + cmd = exec ++ ' ' : params ++ + (if null profParams then "" else " +RTS " ++ show profParams) diff --git a/Profiling/Heap/Read.hs b/Profiling/Heap/Read.hs new file mode 100644 --- /dev/null +++ b/Profiling/Heap/Read.hs @@ -0,0 +1,376 @@ +{-| + +This module defines the functions that access heap profiles both +during and after execution. + +-} + +module Profiling.Heap.Read + ( + -- * Reading archived profiles + readProfile + , LoadProgress + , ProfilingStop + , readProfileAsync + -- * Profiling running applications + , ProfileReader + , ProfilingType(..) + , ProfilingCommand + , ProfilingInfo + , profile + , profileCallback + ) where + +-- The imperative bits +import Control.Applicative +import Control.Arrow +import Control.Monad +import Control.Monad.Fix +import Control.Concurrent +import Data.IORef +import System.Directory +import System.FilePath +import System.IO +import System.Process + +-- Data structures +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.List +import Data.Maybe +import qualified Data.IntMap as IM +import Data.Trie (Trie) +import qualified Data.Trie as T +import Profiling.Heap.Types + +-- Networking +import Network +import Profiling.Heap.Network + +-- Stuff needed only to create a time stamp +import Data.Time.LocalTime (getZonedTime) +import Data.Time.Format (formatTime) +import System.Locale (defaultTimeLocale) + +{-| The simplest case to handle is the traditional method of taking +the profiler output of an earlier run and turning it into an easy to +query structure. This is done by passing 'readProfile' the log created +by the heap profiler (a file with .hp extension). -} + +readProfile :: FilePath -> IO (Maybe Profile) +readProfile file = flip catch (const (return Nothing)) $ do + hdl <- openFile file ReadMode + let parse stime prof = do + stop <- hIsEOF hdl + if not stop then do + (stime',prof') <- accumProfile stime prof <$> S.hGetLine hdl + parse stime' $! prof' + else return prof + + prof <- parse Nothing emptyProfile + return $ if null (prJob prof) then Nothing else Just prof + +{-| If we want to observe the progress of loading, we can perform the +operation asynchronously. We need a query operation to check the +progress and extract the final result after the whole profile was +loaded. A 'LoadProgress' computation tells us precisely that, +representing progress with a number between 0 and 1. -} + +type LoadProgress = IO (Either Double Profile) + +{-| A common stopping action that can be used to cancel asynchronous +loading as well as killing the reading thread during live profiling +without touching the slave process. -} + +type ProfilingStop = IO () + +{-| Read a heap profile asynchronously. Since we might want to +interrupt the loading process if it proves to be too long, a stopper +action is also returned along with the progress query action. If the +stopper action is executed, the query function will return an empty +profile as a result. -} + +readProfileAsync :: FilePath -> IO (LoadProgress,ProfilingStop) +readProfileAsync file = do + progress <- newIORef (Left 0) + hdl <- openFile file ReadMode + totalSize <- fromIntegral <$> hFileSize hdl + + let parse stime prof size = do + stop <- hIsEOF hdl + if not stop then do + line <- S.hGetLine hdl + let (stime',prof') = accumProfile stime prof line + size' = size + S.length line + 1 + writeIORef progress . Left $! size' + prof' `seq` parse stime' prof' size' + else writeIORef progress (Right prof) + + tid <- forkIO $ parse Nothing emptyProfile 0 + + return ( left (\s -> fromIntegral s/totalSize) <$> readIORef progress + , killThread tid >> writeIORef progress (Right emptyProfile) + ) + +{-| Since we want to possibly look at heap profiles during the run, we +might need an action that returns the data recorded so far. -} + +type ProfileReader = IO Profile + +{-| There are two basic ways of profiling: local and remote. Local +profiling means that we directly manage the process we are monitoring. +In the case of remote profiling we connect to a server that streams +profiling information and acts as a proxy between the process to +profile and our program. The type of profiling also determines the +kind of information available to us after initiating the process, so +we need generic labels to distinguish the alternatives. -} + +data ProfilingType loc rem = Local { local :: loc } + | Remote { remote :: rem } + +{-| The input of the profiling functions. When we start profiling, we +need a process descriptor for the local case or a server address (of +the form \"address:port\") in the remote case. The creation of the +process descriptor is aided by the "Profiling.Heap.Process" module. -} + +type ProfilingCommand = ProfilingType CreateProcess String + +{-| The return value of the profiling functions. In the local case we +are given the handle of the process monitored. Asking for a remote +profile gives us a handle we can use to communicate with the proxy via +the common protocol defined in the "Profiling.Heap.Network" module. -} + +type ProfilingInfo = ProfilingType ProcessHandle Handle + +{-| In order to perform real-time profiling, we need to fire up the +program to analyse and create an accumulator in the background that we +can look at whenever we want using the reading action returned by the +function. We are also given a stopping action and the handle to the +slave process or network connection depending on the type of +profiling. If there is a problem, 'Nothing' is returned. -} + +profile :: ProfilingCommand -> IO (Maybe (ProfileReader,ProfilingStop,ProfilingInfo)) +profile prog = do + let getCmd p = case cmdspec p of + ShellCommand cmd -> cmd + RawCommand prg args -> intercalate " " (prg:args) + zt <- getZonedTime + ref <- newIORef emptyProfile + { prJob = case prog of + Local desc -> getCmd desc + Remote addr -> addr + -- The time format is deliberately different from the + -- one currently used in heap profiles. Changing it + -- doesn't hurt anyone, and it makes more sense this + -- way, so there. + , prDate = formatTime defaultTimeLocale "%F %H:%M:%S %Z" zt + } + (fmap.fmap) (\(stop,info) -> (readIORef ref,stop,info)) $ profileCallback prog $ \pkg -> do + prof <- readIORef ref + case pkg of + SinkSample t smp -> writeIORef ref $ prof + { prSamples = (t,smp) : prSamples prof } + SinkId ccid ccname -> writeIORef ref $ prof + { prNames = IM.insert ccid ccname (prNames prof) } + _ -> return () + +{-| The 'profileCallback' function initiates an observation without +maintaining any internal data other than the name mapping, passing +profile samples to the callback (provided in the second argument) as +they come. It returns the handle of the new process or the remote +connection as well as the thread stopper action, assuming that a heap +profile could be found. -} + +profileCallback :: ProfilingCommand -> ProfileSink -> IO (Maybe (ProfilingStop,ProfilingInfo)) +profileCallback (Local prog) sink = do + dir <- getCurrentDirectory + let hpPath = fromMaybe dir (cwd prog) ++ + '/' : (takeFileName . execPath . cmdspec) prog ++ ".hp" + -- Yes, this is extremely naive, but it will do for the time being... + execPath (ShellCommand cmd) = takeWhile (/=' ') cmd + execPath (RawCommand path _) = path + + -- We have to delete the .hp file and wait for the process to create it. + catch (removeFile hpPath) (const (return ())) + (_,_,_,phdl) <- createProcess prog + + maybeHpFile <- tryRepeatedly (openFile hpPath ReadMode) 50 10000 + + case maybeHpFile of + Nothing -> return Nothing + Just hpFile -> do + -- Question: do we want an alternative single-threaded interface? + tid <- forkIO $ do + let pass buf idmap smp = do + case S.elemIndex '\n' buf of + -- If there's a whole line in the buffer and we still + -- have the green light, we'll parse it and notify the + -- callback (sink) if necessary. + Just len -> do + let (line,rest) = S.splitAt len buf + -- Getting rid of the line break after the first + -- line. + next = pass (S.drop 1 rest) + + case parseHpLine line of + -- Initialising a new empty sample. + BeginSample _ -> next idmap [] + -- Sending non-empty sample and forgetting it. + EndSample t -> do + when (not (null smp)) $ sink (SinkSample t smp) + next idmap [] + -- Adding a cost to the current sample and checking if + -- we already know the name of the cost centre. + Cost ccname cost -> do + let (newid,ccid,idmap') = addCCId idmap ccname + when newid $ sink (SinkId ccid ccname) + next idmap' ((ccid,cost):smp) + _ -> next idmap smp + + -- If there's no line known to be full while the other + -- process is still running, we keep trying to fetch more + -- data. + Nothing -> do + -- Checking if there is still hope for more data. + slaveCode <- getProcessExitCode phdl + + if slaveCode == Nothing then do + eof <- hIsEOF hpFile + if eof then do + threadDelay 100000 + pass buf idmap smp + else do + newChars <- S.hGetNonBlocking hpFile 0x10000 + pass (S.append buf newChars) idmap smp + -- The other process ended, let's notify the callback. + else sink SinkStop + + pass S.empty T.empty [] + + return (Just (profileStop tid sink,Local phdl)) + +profileCallback (Remote server) sink = do + -- Yeah, we might need some error handling here... + let (addr,_:port) = span (/=':') server + portNum :: Int + portNum = read port + hdl <- connectTo addr ((PortNumber . fromIntegral) portNum) + hSetBuffering hdl LineBuffering + + tid <- forkIO . fix $ \readLoop -> do + -- We assume line buffering here. Also, if there seems to be + -- any error, the profile reader is stopped. + msg <- catch (readMsg <$> hGetLine hdl) (const . return . Just . Stream $ SinkStop) + case msg >>= getStream of + Just profSmp -> do + sink profSmp + when (profSmp /= SinkStop) readLoop + Nothing -> readLoop + + return (Just (profileStop tid sink,Remote hdl)) + +profileStop :: ThreadId -> ProfileSink -> IO () +profileStop tid sink = do + killThread tid + -- The sink is notified asynchronously, since it might be a blocking + -- operation (like the MVar operations used by the grapher). + forkIO (sink SinkStop) + return () + +tryRepeatedly :: IO a -> Int -> Int -> IO (Maybe a) +tryRepeatedly act n d | n < 1 = return Nothing + | otherwise = catch (Just <$> act) (const retry) + where retry = do threadDelay d + tryRepeatedly act (n-1) d + +{- + +JOB "command" +DATE "date" +SAMPLE_UNIT "..." +VALUE_UNIT "..." +BEGIN_SAMPLE t1 +ccname1cost1 +ccname2cost2 +... +END_SAMPLE t1 +BEGIN_SAMPLE t2 +... +-} + +-- The information we care about. +data ParseResult = Unknown + | Job String + | Date String + | BeginSample Time + | EndSample Time + | Cost CostCentreName Cost + +-- Parse a single line of a .hp file. +parseHpLine :: ByteString -> ParseResult +parseHpLine line + | S.null cost = head ([val | (key,val) <- results, key == cmd] ++ [Unknown]) + | otherwise = Cost ccname (read . S.unpack . S.tail $ cost) + where (ccname,cost) = S.span (/='\t') line + (cmd,sparam) = S.span (/=' ') line + param = S.unpack (S.tail sparam) + results = if S.null sparam then [] else + [(S.pack "JOB",Job (read param)), + (S.pack "DATE",Date (read param)), + (S.pack "BEGIN_SAMPLE",BeginSample (read param)), + (S.pack "END_SAMPLE",EndSample (read param))] + +-- Accumulate the results of parsing a single line. +accumProfile :: Maybe Time -> Profile -> ByteString -> (Maybe Time,Profile) +accumProfile time prof line = case parseHpLine line of + Job s -> (Nothing,prof { prJob = s }) + Date s -> (Nothing,prof { prDate = s }) + BeginSample t -> (Just t,prof) + EndSample _ -> (Nothing,prof) + Cost ccname cost -> let (newid,ccid,pnsi') = addCCId (prNamesInv prof) ccname + t = fromJust time + smps = prSamples prof + smps' | null smps = [(t,[(ccid,cost)])] + | otherwise = if t == fst (head smps) then + (fmap ((ccid,cost):) (head smps)) : tail smps + else (t,[(ccid,cost)]) : smps + in (time, + prof + { prSamples = smps' + , prNames = if newid then IM.insert ccid ccname (prNames prof) else prNames prof + , prNamesInv = pnsi' + }) + Unknown -> (Nothing,prof) + +-- Get the id of a name, creating a new one when needed. +addCCId :: Trie CostCentreId -> CostCentreName -> (Bool, CostCentreId, Trie CostCentreId) +addCCId idmap ccname = if ccid /= T.size idmap then (False,ccid,idmap) + else (True,ccid,T.insert ccname ccid idmap) + where ccid = fromMaybe (T.size idmap) (T.lookup ccname idmap) + +-- Some tests -- + +-- For the time being, we assume that getCurrentDirectory returns the +-- dir of the cabal file, because we love emacs. + +-- Callback test (also: stopTest <- fst . fromJust <$> _test1) +_test1 :: IO (Maybe (ProfilingStop,ProfilingInfo)) +_test1 = do + dir <- getCurrentDirectory + profileCallback (Local (shell (dir++"/test/tester")) { cwd = Just (dir++"/test") }) print + +-- Accumulation test +_test2 :: IO () +_test2 = do + dir <- getCurrentDirectory + Just (reader,_,_) <- profile (Local (shell (dir++"/test/tester")) { cwd = Just (dir++"/test") }) + replicateM_ 5 $ do + prof <- reader + print prof + threadDelay 1000000 + +-- Archive test +_test3 :: IO Profile +_test3 = do + dir <- getCurrentDirectory + fromJust <$> (readProfile $ dir ++ "/test/example.hp") diff --git a/Profiling/Heap/Stats.hs b/Profiling/Heap/Stats.hs new file mode 100644 --- /dev/null +++ b/Profiling/Heap/Stats.hs @@ -0,0 +1,125 @@ +{-| This module defines a heap profile data structure optimised for +querying various statistics, but not suitable for continuous +updating. -} + +module Profiling.Heap.Stats + ( ProfileWithStats + , buildStats + ) where + +import Control.Arrow +import qualified Data.IntMap as IM +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Profiling.Heap.Types + +{-| A tree to accelerate range max and maxsum queries. It takes O(n) +to construct and requires O(n) space (where n is the total number of +individual costs), and provides O(log(n)) query time. Note: there are +more sophisticated algorithms allowing constant time access while +keeping the other characteristics as well. -} + +data MaxQuery key val = Leaf (val,val) key + | Node ((val,val),(key,key)) (MaxQuery key val) (MaxQuery key val) + +{-| A data structure providing profile statistics at a low cost. It +accelerates interval extraction as well as determining maxima and +integrals over any subinterval: all of these operations take +logarithmic time to execute. -} + +data ProfileWithStats = PWS + { pmProfile :: Profile + , pmData :: Map Time ProfileSample + , pmIntegral :: Map Time ProfileSample + , pmMaxQuery :: MaxQuery Time Cost + } + +instance ProfileQuery ProfileWithStats where + job = job . pmProfile + date = date . pmProfile + ccNames = ccNames . pmProfile + samples = M.assocs . pmData + -- An interval can be extracted by splitting the map twice (which + -- is a logarithmic operation). + samplesIvl p t1 t2 = M.assocs . fst . M.split t2 . snd . M.split t1 $ pmData p + + -- Starting and ending time can be found in O(log n) steps. + minTime p | M.null (pmData p) = 0 + | otherwise = fst . M.findMin $ pmData p + maxTime p | M.null (pmData p) = 0 + | otherwise = fst . M.findMax $ pmData p + + -- Range maxima can be found in logarithmic time in general, but + -- maxima for the full range are readily available. + maxCost p = case pmMaxQuery p of + Leaf (x,_) _ -> x + Node ((x,_),_) _ _ -> x + maxCostTotal p = case pmMaxQuery p of + Leaf (_,x) _ -> x + Node ((_,x),_) _ _ -> x + maxCostIvl p t1 t2 = fst (maxIvl (pmMaxQuery p) t1 t2) + maxCostTotalIvl p t1 t2 = snd (maxIvl (pmMaxQuery p) t1 t2) + + -- Range integrals can be found in logarithmic time. + integral p | M.null (pmIntegral p) = [] + | otherwise = snd . M.findMax $ pmIntegral p + integralIvl p t1 t2 | M.null ivl = [] + | otherwise = IM.assocs $ diff smp2 smp1 + where ivl = fst . M.split t2 . snd . M.split t1 $ pmIntegral p + smp1 = IM.fromDistinctAscList . snd $ M.findMin ivl + smp2 = IM.fromDistinctAscList . snd $ M.findMax ivl + diff s2 s1 = IM.unionWith (-) s2 s1 + +{-| Create extra data to speed up various queries. -} + +buildStats :: Profile -> ProfileWithStats +buildStats p = PWS + { pmProfile = p + , pmData = M.fromDistinctAscList $ samples p + , pmIntegral = M.fromDistinctAscList . buildIntegrals $ samples p + , pmMaxQuery = buildMaxQuery $ samples p + } + +{-| Calculate all the partial integrals from zero to each sample. -} + +buildIntegrals :: [(Time,ProfileSample)] -> [(Time,ProfileSample)] +buildIntegrals = map (fmap IM.assocs) . tail . scanl accumSample (undefined,IM.empty) + where accumSample (_,acc) (t,smp) = (t,foldl' accumCost acc smp) + accumCost acc (ccid,cost) = IM.alter (Just . maybe cost (+cost)) ccid acc + +{-| Build range max-maxsum query tree. -} + +buildMaxQuery :: [(Time,ProfileSample)] -> MaxQuery Time Cost +buildMaxQuery smps = head.head $ dropWhile ((>1).length) $ + iterate mergeList (map smpMaxQuery smps) + where smpMaxQuery (t,smp) = Leaf maxima t + where maxima = (maximum &&& sum) (map snd smp) + + mergeList (t1:t2:ts) = node:mergeList ts + where node = Node ( (max m1 m2,max ms1 ms2) + , (fst (getIvl t1),snd (getIvl t2)) + ) t1 t2 + (m1,ms1) = vmm t1 + (m2,ms2) = vmm t2 + vmm (Leaf x _) = x + vmm (Node (mm,_) _ _) = mm + mergeList ts = ts + +{-| Get the maxima for a given interval. -} + +maxIvl :: MaxQuery Time Cost -> Time -> Time -> (Cost,Cost) +maxIvl (Leaf x _) _ _ = x +maxIvl (Node _ l r) t1 t2 + | t2 < t1r = maxIvl l t1 t2 + | t1 > t2l = maxIvl r t1 t2 + | otherwise = unionIval (maxIvl l t1 t2l) (maxIvl r t1r t2) + where (_t1l,t2l) = getIvl l + (t1r,_t2r) = getIvl r + unionIval (ml,msl) (mr,msr) = (max ml mr,max msl msr) + +{-| Get the interval covered by the query tree. -} + +getIvl :: MaxQuery Time Cost -> (Time,Time) +getIvl (Leaf _ t) = (t,t) +getIvl (Node (_,ivl) _ _) = ivl diff --git a/Profiling/Heap/Types.hs b/Profiling/Heap/Types.hs new file mode 100644 --- /dev/null +++ b/Profiling/Heap/Types.hs @@ -0,0 +1,190 @@ +{-| + +This module defines the commonly used data structures and basic types +of the heap profiling framework. + +Profiling information is a sequence of time-stamped samples, therefore +the ideal data structure should have an efficient snoc operation. +Also, it should make it easy to extract an interval given by a start +and an end time. On top of the raw data, we also want to access some +statistics as efficiently as possible. + +We can separate two phases: looking at the profile during execution +and later. In the first case we might not want statistics, just live +monitoring, while we probably want to analyse archived profiles more +deeply. Therefore, it makes sense to define two separate data +structures for these two purposes, and give them a common interface +for extracting the necessary data. The simple case is covered by the +'Profile' type defined here, while a more complex structure providing +fast off-line queries is defined in the "Profiling.Heap.Stats" module. + +-} + +module Profiling.Heap.Types + ( CostCentreId + , CostCentreName + , Time + , Cost + , ProfileSample + -- * Profile data structure + , Profile(..) + , emptyProfile + -- * Query interface + , ProfileQuery(..) + -- * Streaming interface + , ProfileSink + , SinkInput(..) + ) where + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.Int +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.List +import Data.Trie (Trie) +import qualified Data.Trie as T + +{-| The 'ProfileQuery' class contains all kinds of reading operations. +The minimal definition consists of 'job', 'date', 'ccNames' and +'samples'. All the statistics have default implementations, which are +mostly okay for a single query, but they are generally highly +inefficient. -} + +class ProfileQuery p where + -- | Job information (command line). + job :: p -> String + -- | Job start time. + date :: p -> String + -- | Cost centre id to name mapping. + ccNames :: p -> IntMap CostCentreName + -- | Find cost centre name by id. + ccName :: p -> Int -> CostCentreName + ccName p ccId = IM.findWithDefault S.empty ccId (ccNames p) + + -- | The measurements in a list ordered by time. + samples :: p -> [(Time,ProfileSample)] + -- | The samples between two given times. + samplesIvl :: p -> Time -> Time -> [(Time,ProfileSample)] + samplesIvl p t1 t2 = takeWhile (( Time + minTime p | null smp = 0 + | otherwise = fst (head smp) + where smp = samples p + -- | The time of the last sample. + maxTime :: p -> Time + maxTime p | null smp = 0 + | otherwise = fst (last smp) + where smp = samples p + + -- | The highest individual cost at any time. + maxCost :: p -> Cost + maxCost p = maximum $ 0:[c | (_,s) <- samples p, (_,c) <- s] + -- | The highest total cost at any time. + maxCostTotal :: p -> Cost + maxCostTotal p = maximum $ 0:[sum (map snd s) | (_,s) <- samples p] + -- | The highest individual cost in the interval. + maxCostIvl :: p -> Time -> Time -> Cost + maxCostIvl p t1 t2 = maximum $ 0:[c | (_,s) <- samplesIvl p t1 t2, (_,c) <- s] + -- | The highest total cost in the interval. + maxCostTotalIvl :: p -> Time -> Time -> Cost + maxCostTotalIvl p t1 t2 = maximum $ 0:[sum (map snd s) | (_,s) <- samplesIvl p t1 t2] + + -- | The total cost of each cost centre. Not a time integral; + -- samples are simply summed. + integral :: p -> ProfileSample + integral = integral' . samples + -- | The total cost of each cost centre in the interval. + integralIvl :: p -> Time -> Time -> ProfileSample + integralIvl p t1 t2 = integral' (samplesIvl p t1 t2) + +integral' :: [(Time,ProfileSample)] -> ProfileSample +integral' = IM.assocs . foldl' accumSample IM.empty + where accumSample acc = foldl' accumCost acc . snd + accumCost acc (ccid,cost) = IM.alter (Just . maybe cost (+cost)) ccid acc + +{-| A raw heap profile that's easy to grow further, therefore it is +used during loading. -} + +data Profile = Profile + { prSamples :: ![(Time,ProfileSample)] -- ^ Samples in decreasing time order (latest first). + , prNames :: !(IntMap CostCentreName) -- ^ A map from cost centre ids to names. + , prNamesInv :: !(Trie CostCentreId) -- ^ A map from cost centre names to ids. + , prJob :: !String -- ^ Information about the job (command line). + , prDate :: !String -- ^ Job start time and date. + } deriving Eq + +instance Show Profile where + show p = unlines $ + ["Job: " ++ prJob p + ,"Date: " ++ prDate p + ,"Name mappings:"] ++ + (map show . IM.assocs . prNames) p ++ + ["Measurements:"] ++ + (map show . prSamples) p + +instance ProfileQuery Profile where + job = prJob + date = prDate + ccNames = prNames + samples = reverse . prSamples + +{-| An initial 'Profile' structure that can be used in +accumulations. -} + +emptyProfile :: Profile +emptyProfile = Profile + { prSamples = [] + , prNames = IM.empty + , prNamesInv = T.empty + , prJob = "" + , prDate = "" + } + +{-| Cost centres are identified by integers for simplicity (so we can +use IntMap). -} + +type CostCentreId = Int + +{-| At this level cost centre names have no internal structure that we +would care about. While in some cases they reflect the call +hierarchy, we are not splitting them at this point, because all kinds +of names can appear here. -} + +type CostCentreName = ByteString + +{-| Time is measured in seconds. -} + +type Time = Double + +{-| Costs are measured in bytes. -} + +type Cost = Int64 + +{-| A sampling point is simply a list of cost centres with the +associated cost. There is no need for a fancy data structure here, +since we normally process every value in this collection, and it's +usually not big either, only holding a few dozen entries at most. -} + +type ProfileSample = [(CostCentreId,Cost)] + +{-| We might not want to hold on to all the past output, just do some +stream processing. We can achieve this using a callback function +that's invoked whenever a new profile sample is available. The type +of this function can be 'ProfileSink'. Besides the actual costs, it +is also necessary to send over the names that belong to the short cost +centre identifiers as well as the fact that no more data will come. +The 'SinkInput' type expresses these possibilities. -} + +type ProfileSink = SinkInput -> IO () + +data SinkInput + -- | A snapshot of costs at a given time. + = SinkSample !Time !ProfileSample + -- | The name behind a cost centre id used in the samples. + | SinkId !CostCentreId !CostCentreName + -- | Indication that no more data will come. + | SinkStop + deriving (Eq, Show) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,8 @@ +Testing: + +1. Go to the test directory and compile tester. +2. Load Profiling.Heap.Read into ghci. +3. Change to the dir that contains the cabal file (you should be + already there if you performed the second step from Emacs). +4. Now you can try _test{1,2,3} as you please. You might want to delete + test/tester.hp between tests. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hp2any-core.cabal b/hp2any-core.cabal new file mode 100644 --- /dev/null +++ b/hp2any-core.cabal @@ -0,0 +1,42 @@ +Name: hp2any-core +Version: 0.9.0 +Cabal-Version: >= 1.2 +Synopsis: Heap profiling helper library +Category: profiling, development, utils +Description: + + This is the core library of the hp2any suite. It makes heap profiles + available during runtime through a simple interface, optionally + managing all the data in the background. It can also process + archived profiler output and present it in a structured form. + +Author: Patai Gergely +Maintainer: Patai Gergely (patai@iit.bme.hu) +Copyright: (c) 2009, Patai Gergely +License: BSD3 +License-File: LICENSE +Stability: experimental +Build-Type: Simple +Extra-Source-Files: + CHANGES + README + test/example.hp + test/tester.hs +Extra-Tmp-Files: + test/tester + test/tester.hi + test/tester.hp + test/tester.o + +Library + Exposed-Modules: + Profiling.Heap.Read + Profiling.Heap.Process + Profiling.Heap.Network + Profiling.Heap.Stats + Profiling.Heap.Types + + Build-Depends: base >= 4 && < 5, containers, time, directory, + filepath, process, old-locale, network, + bytestring, bytestring-trie + ghc-options: -Wall -O2 diff --git a/test/example.hp b/test/example.hp new file mode 100644 --- /dev/null +++ b/test/example.hp @@ -0,0 +1,82 @@ +JOB "SomeFunProgram +RTS -P -hd -L50" +DATE "Wed Mar 25 18:37 2009" +SAMPLE_UNIT "seconds" +VALUE_UNIT "bytes" +BEGIN_SAMPLE 0.00 +END_SAMPLE 0.00 +BEGIN_SAMPLE 0.08 +W32# 16 + 16 +I# 16 + 24 +MVAR 32 +MVar 16 +ThreadId 16 +MUT_VAR_CLEAN 32 +STRef 32 +Ptr 16 +CAF_BLACKHOLE 32 + 16 + 16 +WEAK 40 +END_SAMPLE 0.08 +BEGIN_SAMPLE 0.20 +MUT_ARR_PTRS_FROZEN 8824 +MUT_VAR_CLEAN 32 +STRef 32 +Ptr 16 +MVAR 32 +MVar 16 + 16 +WEAK 40 + 16 + 24 +StateVar 48 +PAP 32 + 24 +Array 40 +:% 72 + 32 + 32 + 24 +I32# 80 + 16 + 16 + 24 + 16 +W32# 48 + 16 +S# 176 +: 2623800 +W8# 1749248 +ThreadId 16 + 26304 +BLACKHOLE 16 +END_SAMPLE 0.20 +BEGIN_SAMPLE 0.30 +MUT_ARR_PTRS_FROZEN 8824 +MUT_VAR_CLEAN 32 +STRef 32 +Ptr 16 +MVAR 32 +MVar 16 + 16 +WEAK 40 + 64 + 64 +StateVar 48 + 32 + 24 +W32# 80 + 16 +PAP 64 + 24 +Array 40 +:% 72 +S# 176 +W8# 216960 +: 325368 +ThreadId 16 + 26304 +BLACKHOLE 16 +END_SAMPLE 0.30 diff --git a/test/tester.hs b/test/tester.hs new file mode 100644 --- /dev/null +++ b/test/tester.hs @@ -0,0 +1,26 @@ +import Control.Concurrent +import System.IO + +main = do + -- Make sure working dir is where the executable is! + putStrLn "Starting tester!" + + hin <- openFile "example.hp" ReadMode + hout <- openFile "tester.hp" WriteMode + + let emit = do + stop <- hIsEOF hin + if not stop then do + line <- hGetLine hin + hPutStrLn hout line + hFlush hout + threadDelay 1000 + emit + else return () + + emit + + hClose hin + hClose hout + + return ()