diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,27 +1,27 @@ -Copyright (c) 2007, 2008 Antiope Associates LLC - +Copyright (c) 2010, Daniel Velkov +Copyright (c) 2011, Kevin Cantu 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 his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY ANTIOPE ASSOCIATES 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 AUTHORS 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. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + +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/Prof2Html.hs b/Prof2Html.hs --- a/Prof2Html.hs +++ b/Prof2Html.hs @@ -12,7 +12,9 @@ import System.Process import System.Directory import System.Environment +import System.FilePath import System.IO.Error +import System.IO import Data.Maybe import GraphUtils import Data.Char @@ -28,20 +30,20 @@ ++ P.prettyPrint 120 tm ++ "" assignSCC :: Module -> Module -assignSCC m = evalState (transformBiM f m) 0 where - f e = do st <- get - put (st + 1) - return $ addSCC st $ strip e - - strip :: Exp_ -> Exp_ - strip (SCCPragma _ e) = e - strip e = e - - addSCC :: Int -> Exp_ -> Exp_ - addSCC _ e@(Var _) = e - addSCC _ e@(Lit _) = e - addSCC num e = Paren $ SCCPragma (show num) e +assignSCC m = evalState (transformBiM f m) 0 + where f e + = do st <- get + put (st + 1) + return $ addSCC st $ strip e + strip :: Exp_ -> Exp_ + strip (SCCPragma _ e) = e + strip e = e + + addSCC :: Int -> Exp_ -> Exp_ + addSCC _ e@(Var _) = e + addSCC _ e@(Lit _) = e + addSCC num e = Paren $ SCCPragma (show num) e addColour m s = gsubRegexPRBy (pref ++ ".*?" ++ suf) (\ str -> pref ++ sccNumToColour str ++ suf) @@ -69,7 +71,7 @@ ++ "00" where pad :: String -> String - pad str = if length str == 1 then '0':str else str + pad str = if length str == 1 then '0' : str else str yellow = 0.1 parseModuleFromFile :: FilePath -> IO Module @@ -105,44 +107,52 @@ trd3 :: (Integer, Integer, Integer) -> Integer trd3 (_, _, x) = x ind l n = if length l > n then Just $ l !! n else Nothing +outputHTML file profName tm + = do putStrLn "parsing profiling results" + profFile <- readFile $ profName + let prof = fromJust $ parseProfile profName profFile + when (profileTicks prof == 0) + (error "the program has to run longer to get enough information") + let profMap = computeTicksMap prof + putStrLn "printing output html file" + let html = addColour profMap $ pprint tm + writeFile (file ++ ".html") html main :: IO () main = do args <- getArgs let mode = args !! 0 - unless ("-h" `isPrefixOf` mode || "-px" `isPrefixOf` mode) - (error "mode should be -h or -px") let file = args !! 1 let run = args !! 2 + unless ("-h" `isPrefixOf` mode || "-px" `isPrefixOf` mode) + (error "mode should be -h or -px") let programArgs = ind args 3 let inpFile = ind args 4 let bak = file ++ ".bak" + let profName = (takeBaseName run) ++ ".prof" (do removeFile bak `catch` - (\ e -> if isDoesNotExistError e then return () else ioError e) + (\ e -> unless (isDoesNotExistError e) $ ioError e) renameFile file bak putStrLn "started parsing original file" m <- parseModuleFromFile bak let tm = assignSCC m putStrLn "writing modified file" writeFile file $ PP.prettyPrint tm - let buildStr - = "ghc -prof -O2 --make " ++ - run ++ ".hs && ./" ++ run ++ " +RTS " ++ mode ++ " -RTS" - let buildStrArgs - = buildStr ++ " " ++ fromMaybe "" programArgs ++ " " - let buildStrInp - = maybe buildStrArgs ((buildStrArgs ++ " < ") ++) inpFile - putStrLn buildStrInp - buildCommand <- runCommand buildStrInp + + let buildStr = "ghc -prof -rtsopts -O2 --make " ++ run ++ ".hs" + putStrLn buildStr + buildCommand <- runCommand buildStr waitForProcess buildCommand - (when ("-px" `isPrefixOf` mode) $ - do putStrLn "parsing profiling results" - profFile <- readFile $ run ++ ".prof" - let prof = fromJust $ parseProfile (run ++ ".prof") profFile - let profMap = computeTicksMap prof - putStrLn "printing output html file" - let html = addColour profMap $ pprint tm - writeFile (file ++ ".html") html) + + let runRTS = ["+RTS", mode, "-RTS"] + let runArgs = runRTS ++ maybe [] words programArgs + inp <- maybe (return Inherit) + (\file -> UseHandle <$> openFile file ReadMode) inpFile + putStrLn $ run ++ " " ++ unwords runArgs + (_,_,_,runCommand) <- createProcess (proc ("./" ++ run) runArgs){std_in = inp} + waitForProcess runCommand + + (when ("-px" `isPrefixOf` mode) (outputHTML file profName tm)) renameFile file (file ++ ".scc")) `Exc.finally` (do copyFile bak file diff --git a/visual-prof.cabal b/visual-prof.cabal --- a/visual-prof.cabal +++ b/visual-prof.cabal @@ -1,5 +1,5 @@ Name: visual-prof -Version: 0.1 +Version: 0.2 Cabal-Version: >= 1.2 License: BSD3 License-file: LICENSE @@ -29,7 +29,7 @@ Executable visual-prof if flag(splitBase) - Build-Depends: base >= 3 && < 4, containers + Build-Depends: base >= 3 && < 5, containers else Build-Depends: base < 3 Build-depends: parsec, filepath, haskell-src-exts, regexpr, directory, process, pretty, mtl, uniplate