Commit c8742f25 authored by andy@galois.com's avatar andy@galois.com
Browse files

updating hpc toolkit

The hpc overlay has been ported from hpc-0.4
The new API for readMix is now used.
parent 5f4e77a5
......@@ -90,7 +90,7 @@ hooks' = [ (name hook,hook) | hook <- hooks ]
help_plugin = Plugin { name = "help"
, usage = "[<HPC_COMMAND>]"
, summary = "Display help for hpc or a single command."
, summary = "Display help for hpc or a single command"
, options = help_options
, implementation = help_main
, init_flags = default_flags
......@@ -122,7 +122,7 @@ version_plugin = Plugin { name = "version"
, final_flags = default_final_flags
}
version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev"
version_main _ _ = putStrLn $ "hpc tools, version 0.6"
------------------------------------------------------------------------------
\ No newline at end of file
------------------------------------------------------------------------------
......@@ -59,7 +59,7 @@ makeDraft hpcflags tix = do
hash = tixModuleHash tix
tixs = tixModuleTixs tix
mix@(Mix filepath timestamp hash tabstop entries) <- readMixWithFlags hpcflags tix
mix@(Mix filepath timestamp hash tabstop entries) <- readMixWithFlags hpcflags (Right tix)
let forest = createMixEntryDom
[ (span,(box,v > 0))
......@@ -71,7 +71,7 @@ makeDraft hpcflags tix = do
let non_ticked = findNotTickedFromList forest
hs <- readFileFromPath filepath (srcDirs hpcflags)
hs <- readFileFromPath (hpcError draft_plugin) filepath (srcDirs hpcflags)
let hsMap :: Map.Map Int String
hsMap = Map.fromList (zip [1..] $ lines hs)
......@@ -136,14 +136,3 @@ findNotTickedFromTree (Node (pos,[]) children) = findNotTickedFromList children
findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick]
findNotTickedFromList = concatMap findNotTickedFromTree
readFileFromPath :: String -> [String] -> IO String
readFileFromPath filename@('/':_) _ = readFile filename
readFileFromPath filename path0 = readTheFile path0
where
readTheFile :: [String] -> IO String
readTheFile [] = error $ "could not find " ++ show filename
++ " in path " ++ show path0
readTheFile (dir:dirs) =
catch (do str <- readFile (dir ++ "/" ++ filename)
return str)
(\ _ -> readTheFile dirs)
......@@ -110,7 +110,7 @@ postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unt
$ \ f -> f { funTotals = True }
-------------------------------------------------------------------------------
readMixWithFlags :: Flags -> TixModule -> IO Mix
readMixWithFlags :: Flags -> Either String TixModule -> IO Mix
readMixWithFlags flags mod = readMix [ dir ++ "/" ++ hpcDir flags
| dir <- srcDirs flags
] mod
......
......@@ -7,6 +7,7 @@ data Token
| SYM Char
| INT Int
| STR String
| CAT String
deriving (Eq,Show)
initLexer :: String -> [Token]
......@@ -16,6 +17,7 @@ lexer :: String -> Int -> Int -> [(Int,Int,Token)]
lexer (c:cs) line column
| c == '\n' = lexer cs (succ line) 0
| c == '\"' = lexerSTR cs line (succ column)
| c == '[' = lexerCAT cs "" line (succ column)
| c `elem` "{};-:"
= (line,column,SYM c) : lexer cs line (succ column)
| isSpace c = lexer cs line (succ column)
......@@ -35,10 +37,15 @@ lexerINT other s line column = (line,column,INT (read s)) : lexer other line co
-- not technically correct for the new column count, but a good approximation.
lexerSTR cs line column
= case lex ('"' : cs) of
[(str,rest)] -> (line,succ column,STR str)
[(str,rest)] -> (line,succ column,STR (read str))
: lexer rest line (length (show str) + column + 1)
_ -> error "bad string"
lexerCAT (c:cs) s line column
| c == ']' = (line,column,CAT s) : lexer cs line (succ column)
| otherwise = lexerCAT cs (s ++ [c]) line (succ column)
lexerCAT other s line column = error "lexer failure in CAT"
test = do
t <- readFile "EXAMPLE.tc"
print (initLexer t)
......
......@@ -9,7 +9,7 @@ import qualified Data.Map as Map
lookup :: Ord key => key -> Map key elt -> Maybe elt
fromList :: Ord key => [(key,elt)] -> Map key elt
fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
#if __GLASGOW_HASKELL__ < 604
type Map key elt = Map.FiniteMap key elt
......@@ -23,5 +23,7 @@ type Map key elt = Map.Map key elt
lookup = Map.lookup
fromList = Map.fromList
toList = Map.toList
fromListWith = Map.fromListWith
#endif
......@@ -10,6 +10,7 @@ import Trace.Hpc.Tix
import Trace.Hpc.Util
import HpcFlags
import HpcUtils
import System.Environment
import System.Directory
......@@ -143,7 +144,7 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
let theHsPath = srcDirs flags
let modName0 = tixModuleName tix
(Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags tix
(Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags (Right tix)
let arr_tix :: Array Int Integer
arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
......@@ -206,7 +207,7 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
}
-- add prefix to modName argument
content <- readFileFromPath origFile theHsPath
content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath
let content' = markup tabStop info content
let show' = reverse . take 5 . (++ " ") . reverse . show
......@@ -450,17 +451,3 @@ red = "#f20913"
green = "#60de51"
yellow = "yellow"
------------------------------------------------------------------------------
readFileFromPath :: String -> [String] -> IO String
readFileFromPath filename@('/':_) _ = readFile filename
readFileFromPath filename path0 = readTheFile path0
where
readTheFile :: [String] -> IO String
readTheFile [] = hpcError markup_plugin
$ "could not find " ++ show filename
++ " in path " ++ show path0
readTheFile (dir:dirs) =
catch (do str <- readFile (dir ++ "/" ++ filename)
return str)
(\ _ -> readTheFile dirs)
......@@ -2,6 +2,12 @@ module HpcOverlay where
import HpcFlags
import HpcParser
import HpcUtils
import Trace.Hpc.Tix
import Trace.Hpc.Mix
import Trace.Hpc.Util
import HpcMap as Map
import Data.Tree
overlay_options
= srcDirOpt
......@@ -20,9 +26,129 @@ overlay_plugin = Plugin { name = "overlay"
overlay_main flags [] = hpcError overlay_plugin $ "no overlay file specified"
overlay_main flags files = do
print ("HERE", files)
result <- hpcParser (head files)
print result
return ()
specs <- mapM hpcParser files
let spec@(Spec globals modules) = concatSpec specs
let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ]
mod_info <-
sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left mod)
content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags)
processModule mod content mix mod_spec globals
| (mod,mod_spec) <- Map.toList modules1
]
let tix = Tix $ mod_info
case outputFile flags of
"-" -> putStrLn (show tix)
out -> writeFile out (show tix)
processModule :: String -- ^ module name
-> String -- ^ module contents
-> Mix -- ^ mix entry for this module
-> [Tick] -- ^ local ticks
-> [ExprTick] -- ^ global ticks
-> IO TixModule
processModule modName modContents (Mix filepath timestamp hash tabstop entries) locals globals = do
let hsMap :: Map.Map Int String
hsMap = Map.fromList (zip [1..] $ lines modContents)
let topLevelFunctions =
Map.fromListWith (++)
[ (nm,[pos])
| (pos,TopLevelBox [nm]) <- entries
]
let inside :: HpcPos -> String -> Bool
inside pos nm =
case Map.lookup nm topLevelFunctions of
Nothing -> False
Just poss -> any (pos `insideHpcPos`) poss
-- TODO: rename plzTick => plzExprTick, plzTopPick => plzTick
let plzTick :: HpcPos -> BoxLabel -> ExprTick -> Bool
plzTick pos (ExpBox _) (TickExpression _ match q g) =
qualifier pos q
&& case match of
Nothing -> True
Just str -> str == grabHpcPos hsMap pos
plzTick _ _ _ = False
plzTopTick :: HpcPos -> BoxLabel -> Tick -> Bool
plzTopTick pos label (ExprTick ignore) = plzTick pos label ignore
plzTopTick pos _ (TickFunction fn q g) =
qualifier pos q && pos `inside` fn
plzTopTick pos label (InsideFunction fn igs) =
pos `inside` fn && any (plzTopTick pos label) igs
let tixs = Map.fromList
[ (ix,
any (plzTick pos label) globals
|| any (plzTopTick pos label) locals)
| (ix,(pos,label)) <- zip [0..] entries
]
let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span)
let forest = createMixEntryDom
[ (span,ix)
| ((span,_),ix) <- zip entries [0..]
]
--
let forest2 = addParentToList [] $ forest
-- putStrLn $ drawForest $ map (fmap show') $ forest2
let isDomList = Map.fromList
[ (ix,filter (/= ix) rng ++ dom)
| (_,(rng,dom)) <- concatMap flatten forest2
, ix <- rng
]
-- We do not use laziness here, because the dominator lists
-- point to their equivent peers, creating loops.
let isTicked n =
case Map.lookup n tixs of
Just v -> v
Nothing -> error $ "can not find ix # " ++ show n
let tixs' = [ case Map.lookup n isDomList of
Just vs -> if any isTicked (n : vs) then 1 else 0
Nothing -> error $ "can not find ix in dom list # " ++ show n
| n <- [0..(length entries - 1)]
]
return $ TixModule modName hash (length tixs') tixs'
qualifier :: HpcPos -> Maybe Qualifier -> Bool
qualifier pos Nothing = True
qualifier pos (Just (OnLine n)) = n == l1 && n == l2
where (l1,c1,l2,c2) = fromHpcPos pos
qualifier pos (Just (AtPosition l1' c1' l2' c2'))
= (l1', c1', l2', c2') == fromHpcPos pos
concatSpec :: [Spec] -> Spec
concatSpec = foldl1 $
\ (Spec pre1 body1) (Spec pre2 body2)
-> Spec (pre1 ++ pre2) (body1 ++ body2)
addParentToTree :: [a] -> MixEntryDom [a] -> MixEntryDom ([a],[a])
addParentToTree path (Node (pos,a) children) =
Node (pos,(a,path)) (addParentToList (a ++ path) children)
addParentToList :: [a] -> [MixEntryDom [a]] -> [MixEntryDom ([a],[a])]
addParentToList path nodes = map (addParentToTree path) nodes
......@@ -31,7 +31,7 @@ import HpcLexer
'}' { SYM '}' }
int { INT $$ }
string { STR $$ }
cat { STR $$ }
cat { CAT $$ }
%%
Spec :: { Spec }
......
......@@ -152,7 +152,7 @@ single (BinBox {}) = False
modInfo :: Flags -> Bool -> TixModule -> IO ModInfo
modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do
Mix _ _ _ _ mes <- readMixWithFlags hpcflags tix
Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix)
return (q (accumCounts (zip (map snd mes) tickCounts) miZero))
where
q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)}
......
......@@ -38,7 +38,7 @@ showtix_main flags (prog:modNames) = do
Nothing -> hpcError showtix_plugin $ "could not read .tix file : " ++ prog
Just (Tix tixs) -> do
tixs_mixs <- sequence
[ do mix <- readMixWithFlags hpcflags1 tix
[ do mix <- readMixWithFlags hpcflags1 (Right tix)
return $ (tix,mix)
| tix <- tixs
, allowModule hpcflags1 (tixModuleName tix)
......
......@@ -2,6 +2,7 @@ module HpcUtils where
import Trace.Hpc.Util
import qualified HpcMap as Map
import HpcFlags
-- turns \n into ' '
-- | grab's the text behind a HpcPos;
......@@ -18,3 +19,14 @@ grabHpcPos hsMap span =
Nothing -> error $ "bad line number : " ++ show n
) [l1..l2]
readFileFromPath :: (String -> IO String) -> String -> [String] -> IO String
readFileFromPath err filename@('/':_) _ = readFile filename
readFileFromPath err filename path0 = readTheFile path0
where
readTheFile [] = err $ "could not find " ++ show filename
++ " in path " ++ show path0
readTheFile (dir:dirs) =
catch (do str <- readFile (dir ++ "/" ++ filename)
return str)
(\ _ -> readTheFile dirs)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment