hp2any-core (empty) → 0.9.0
raw patch · 12 files changed
+1189/−0 lines, 12 filesdep +basedep +bytestringdep +bytestring-triesetup-changed
Dependencies added: base, bytestring, bytestring-trie, containers, directory, filepath, network, old-locale, process, time
Files
- CHANGES +39/−0
- LICENSE +28/−0
- Profiling/Heap/Network.hs +161/−0
- Profiling/Heap/Process.hs +110/−0
- Profiling/Heap/Read.hs +376/−0
- Profiling/Heap/Stats.hs +125/−0
- Profiling/Heap/Types.hs +190/−0
- README +8/−0
- Setup.hs +2/−0
- hp2any-core.cabal +42/−0
- test/example.hp +82/−0
- test/tester.hs +26/−0
+ CHANGES view
@@ -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
+ LICENSE view
@@ -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.
+ Profiling/Heap/Network.hs view
@@ -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)
+ Profiling/Heap/Process.hs view
@@ -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)
+ Profiling/Heap/Read.hs view
@@ -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+ccname1<tab>cost1+ccname2<tab>cost2+...+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")
+ Profiling/Heap/Stats.hs view
@@ -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
+ Profiling/Heap/Types.hs view
@@ -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 ((<t2).fst) $ dropWhile ((<t1).fst) $ samples p++ -- | The time of the first sample.+ minTime :: p -> 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)
+ README view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hp2any-core.cabal view
@@ -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
+ test/example.hp view
@@ -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+<base:Data.List.sum'1_s37d> 16+I# 16+<base:Data.List.sat_s3kS> 24+MVAR 32+MVar 16+ThreadId 16+MUT_VAR_CLEAN 32+STRef 32+Ptr 16+CAF_BLACKHOLE 32+<base:GHC.Enum.go_s2aS> 16+<base:GHC.TopHandler.sat_s1Yv> 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+<base:GHC.TopHandler.sat_s1Yv> 16+WEAK 40+<base:Foreign.C.Error.sat_s2vs> 16+<base:Foreign.C.Error.sat_s2uo> 24+StateVar 48+PAP 32+<base:Data.List.sat_s3kS> 24+Array 40+:% 72+<OpenGL-2.2.1.1:Graphics.Rendering.OpenGL.GL.Texturing.Environments.sat_s3pnb> 32+<OpenGL-2.2.1.1:Graphics.Rendering.OpenGL.GL.Texturing.Environments.sat_s3pny> 32+<base:Foreign.C.Error.pred_s2kz> 24+I32# 80+<OpenGL-2.2.1.1:Graphics.Rendering.OpenGL.GL.Texturing.Objects.sat_s3QwQ> 16+<OpenGL-2.2.1.1:Graphics.Rendering.OpenGL.GL.Texturing.Objects.sat_s3Qxi> 16+<OpenGL-2.2.1.1:Graphics.Rendering.OpenGL.GL.Texturing.Objects.sat_s3QDO> 24+<base:Foreign.Marshal.Array.sat_s1zl> 16+W32# 48+<base:Data.List.sum'1_s37d> 16+S# 176+: 2623800+W8# 1749248+ThreadId 16+<base:GHC.Float.sat_s7ef> 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+<base:GHC.TopHandler.sat_s1Yv> 16+WEAK 40+<OpenGL-2.2.1.1:Graphics.Rendering.OpenGL.GL.Texturing.TexParameter.sat_s2JVb> 64+<OpenGL-2.2.1.1:Graphics.Rendering.OpenGL.GL.Texturing.TexParameter.sat_s2JVy> 64+StateVar 48+<OpenGL-2.2.1.1:Graphics.Rendering.OpenGL.GL.Texturing.Environments.sat_s3pny> 32+<OpenGL-2.2.1.1:Graphics.Rendering.OpenGL.GL.Texturing.Parameters.sat_s3ksh> 24+W32# 80+<base:Data.List.sum'1_s37d> 16+PAP 64+<base:Data.List.sat_s3kS> 24+Array 40+:% 72+S# 176+W8# 216960+: 325368+ThreadId 16+<base:GHC.Float.sat_s7ef> 26304+BLACKHOLE 16+END_SAMPLE 0.30
+ test/tester.hs view
@@ -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 ()