diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2006 Andy Gill, Colin Runciman +Copyright (c) 2007 Andy Gill +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. The names of the authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Trace/Hpc/Mix.hs b/Trace/Hpc/Mix.hs new file mode 100644 --- /dev/null +++ b/Trace/Hpc/Mix.hs @@ -0,0 +1,192 @@ +{-# OPTIONS -cpp #-} +--------------------------------------------------------------- +-- Colin Runciman and Andy Gill, June 2006 +--------------------------------------------------------------- + +-- |Datatypes and file-access routines for the per-module (.mix) +-- indexes used by Hpc. +module Trace.Hpc.Mix + ( Mix(..) + , MixEntry + , BoxLabel(..) + , CondBox(..) + , mixCreate + , readMix + , Trace.Hpc.Mix.getModificationTime + , createMixEntryDom + , MixEntryDom + ) + where + +import System.Time (ClockTime(..)) +import System.Directory (getModificationTime) +import System.IO (FilePath) +import Data.Maybe (catMaybes) +import Data.Tree +import Data.Char + +-- a module index records the attributes of each tick-box that has +-- been introduced in that module, accessed by tick-number position +-- in the list + +import Trace.Hpc.Util (HpcPos, insideHpcPos, Hash, HpcHash(..)) +import Trace.Hpc.Tix + +-- | 'Mix' is the information about a modules static properties, like +-- location of Tix's in a file. +-- tab stops are the size of a tab in the provided line:colunm values. +-- * In GHC, this is 1 (a tab is just a character) +-- * With hpc-tracer, this is 8 (a tab represents several spaces). + +data Mix = Mix + FilePath -- location of original file + Integer -- time (in seconds) of original file's last update, since 1970. + Hash -- hash of mix entry + timestamp + Int -- tab stop value. + [MixEntry] -- entries + deriving (Show,Read) + +-- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before, +-- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do, +-- because if some other program also defined that instance, we will not be able to compile. + +type MixEntry = (HpcPos, BoxLabel) + +data BoxLabel = ExpBox Bool -- isAlt + | TopLevelBox [String] + | LocalBox [String] + | BinBox CondBox Bool + deriving (Read, Show, Eq, Ord) + +data CondBox = GuardBinBox + | CondBinBox + | QualBinBox + deriving (Read, Show, Eq, Ord) + +instance HpcHash BoxLabel where + toHash (ExpBox b) = 0x100 + toHash b + toHash (TopLevelBox nm) = 0x200 + toHash nm + toHash (LocalBox nm) = 0x300 + toHash nm + toHash (BinBox cond b) = 0x400 + toHash (cond,b) + +instance HpcHash CondBox where + toHash GuardBinBox = 0x10 + toHash CondBinBox = 0x20 + toHash QualBinBox = 0x30 + + +-- | Create is mix file. +mixCreate :: String -- ^ Dir Name + -> String -- ^ module Name + -> Mix -- ^ Mix DataStructure + -> IO () +mixCreate dirName modName mix = + writeFile (mixName dirName modName) (show mix) + +-- | Read a mix file. +readMix :: [String] -- ^ Dir Names + -> Either String TixModule -- ^ module wanted + -> IO Mix +readMix dirNames mod' = do + let modName = case mod' of + Left str -> str + Right tix -> tixModuleName tix + res <- sequence [ (do contents <- readFile (mixName dirName modName) + case reads contents of + [(r@(Mix _ _ h _ _),cs)] + | all isSpace cs + && (case mod' of + Left _ -> True + Right tix -> h == tixModuleHash tix + ) -> return $ Just r + _ -> return $ Nothing) `catch` (\ _ -> return $ Nothing) + | dirName <- dirNames + ] + case catMaybes res of + [r] -> return r + xs@(_:_) -> error $ "found " ++ show(length xs) ++ " instances of " ++ modName ++ " in " ++ show dirNames + _ -> error $ "can not find " ++ modName ++ " in " ++ show dirNames + +mixName :: FilePath -> String -> String +mixName dirName name = dirName ++ "/" ++ name ++ ".mix" + +-- | Get modification time of a file. + +getModificationTime :: FilePath -> IO Integer +getModificationTime file = do + (TOD sec _) <- System.Directory.getModificationTime file + return $ sec + +------------------------------------------------------------------------------ + +type MixEntryDom a = Tree (HpcPos,a) + +-- A good tree has all its children fully inside its parents HpcPos. +-- No child should have the *same* HpcPos. +-- There is no ordering to the children + +isGoodNode :: MixEntryDom a -> Bool +isGoodNode (Node (pos,_) sub_nodes) = + and [ pos' `insideHpcPos` pos | Node(pos',_) _ <- sub_nodes ] + && and [ pos' /= pos | Node(pos',_) _ <- sub_nodes ] + && isGoodForest sub_nodes + +-- all sub-trees are good trees, and no two HpcPos are inside each other. +isGoodForest :: [MixEntryDom a] -> Bool +isGoodForest sub_nodes = + all isGoodNode sub_nodes + && and [ not (pos1 `insideHpcPos` pos2 || + pos2 `insideHpcPos` pos1) + | (Node (pos1,_) _,n1) <- zip sub_nodes [0..] + , (Node (pos2,_) _,n2) <- zip sub_nodes [0..] + , (n1 :: Int) /= n2 ] + +addNodeToTree :: (Show a) => (HpcPos,a) -> MixEntryDom [a] -> MixEntryDom [a] +addNodeToTree (new_pos,new_a) (Node (pos,a) children) + | pos == new_pos = Node (pos,new_a : a) children + | new_pos `insideHpcPos` pos = + Node (pos,a) (addNodeToList (new_pos,new_a) children) + | pos `insideHpcPos` new_pos = + error "precondition not met inside addNodeToNode" + | otherwise = error "something impossible happened in addNodeToTree" + +addNodeToList :: Show a => (HpcPos,a) -> [MixEntryDom [a]] -> [MixEntryDom [a]] +addNodeToList (new_pos,new_a) entries + | otherwise = + if length [ () + | (am_inside,am_outside,_) <- entries' + , am_inside || am_outside + ] == 0 + -- The case where we have a new HpcPos range + then Node (new_pos,[new_a]) [] : entries else + if length [ () + | (am_inside,_,_) <- entries' + , am_inside + ] > 0 + -- The case where we are recursing into a tree + -- Note we can recurse down many branches, in the case of + -- overlapping ranges. + -- Assumes we have captures the new HpcPos + -- (or the above conditional would be true) + then [ if i_am_inside -- or the same as + then addNodeToTree (new_pos,new_a) node + else node + | (i_am_inside,_,node) <- entries' + ] else + -- The case of a super-range. + ( Node (new_pos,[new_a]) + [ node | (_,True,node) <- entries' ] : + [ node | (_,False,node) <- entries' ] + ) + where + entries' = [ ( new_pos `insideHpcPos` pos + , pos `insideHpcPos` new_pos + , node) + | node@(Node (pos,_) _) <- entries + ] + +createMixEntryDom :: (Show a) => [(HpcPos,a)] -> [MixEntryDom [a]] +createMixEntryDom entries + | isGoodForest forest = forest + | otherwise = error "createMixEntryDom: bad forest" + where forest = foldr addNodeToList [] entries diff --git a/Trace/Hpc/Reflect.hsc b/Trace/Hpc/Reflect.hsc new file mode 100644 --- /dev/null +++ b/Trace/Hpc/Reflect.hsc @@ -0,0 +1,75 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +module Trace.Hpc.Reflect + ( clearTix + , examineTix + , updateTix + ) where + +import Foreign.C.String +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable ( Storable(..) ) +import Data.Word +import Data.Int +import Trace.Hpc.Tix +import Trace.Hpc.Util +import System.IO.Unsafe + +#include "Rts.h" + +foreign import ccall unsafe hs_hpc_rootModule :: IO (Ptr ()) + +modInfo :: [ModuleInfo] +modInfo = unsafePerformIO $ do + ptr <- hs_hpc_rootModule + moduleInfoList ptr + +data ModuleInfo = ModuleInfo String Int Hash (Ptr Word64) + +moduleInfoList :: Ptr () -> IO [ModuleInfo] +moduleInfoList ptr + | ptr == nullPtr = return [] + | otherwise = do + cModName <- (#peek HpcModuleInfo, modName) ptr + modName <- peekCString cModName + tickCount <- (#peek HpcModuleInfo, tickCount) ptr + hashNo <- (#peek HpcModuleInfo, hashNo) ptr + tixArr <- (#peek HpcModuleInfo, tixArr) ptr + next <- (#peek HpcModuleInfo, next) ptr + rest <- moduleInfoList next + return $ ModuleInfo modName tickCount (toHash (hashNo :: Int)) tixArr : rest + +clearTix :: IO () +clearTix = do + sequence_ [ pokeArray ptr $ take count $ repeat 0 + | ModuleInfo _mod count _hash ptr <- modInfo + ] + return () + + +examineTix :: IO Tix +examineTix = do + mods <- sequence [ do tixs <- peekArray count ptr + return $ TixModule mod' hash count + $ map fromIntegral tixs + | (ModuleInfo mod' count hash ptr) <- modInfo + ] + return $ Tix mods + +-- requirement that the tix be of the same shape as the +-- internal tix. +updateTix :: Tix -> IO () +updateTix (Tix modTixes) + | length modTixes /= length modInfo = error "updateTix failed" + | otherwise = do + sequence_ [ pokeArray ptr $ map fromIntegral tixs + | (ModuleInfo mod1 count1 hash1 ptr, + TixModule mod2 hash2 count2 tixs) <- zip modInfo modTixes + , if mod1 /= mod2 + || count1 /= count2 + || hash1 /= hash2 + || length tixs /= count2 + then error "updateTix failed" + else True + ] + return () diff --git a/Trace/Hpc/Tix.hs b/Trace/Hpc/Tix.hs new file mode 100644 --- /dev/null +++ b/Trace/Hpc/Tix.hs @@ -0,0 +1,62 @@ +------------------------------------------------------------ +-- Andy Gill and Colin Runciman, June 2006 +------------------------------------------------------------ + +-- | Datatypes and file-access routines for the tick data file +-- used by HPC. (.tix) +module Trace.Hpc.Tix(Tix(..), TixModule(..), + tixModuleName, tixModuleHash, tixModuleTixs, + readTix, writeTix, getTixFileName) where + +import Data.List (isSuffixOf) +import Trace.Hpc.Util(Hash) + +-- 'Tix ' is the storage format for our dynamic imformation about what +-- boxes are ticked. +data Tix = Tix [TixModule] + deriving (Read, Show, Eq) + +data TixModule = TixModule + String -- module name + Hash -- hash number + Int -- length of tix list (allows pre-allocation at parse time). + [Integer] -- actual ticks + deriving (Read, Show, Eq) + +tixModuleName :: TixModule -> String +tixModuleName (TixModule nm _ _ _) = nm +tixModuleHash :: TixModule -> Hash +tixModuleHash (TixModule _ h _ _) = h +tixModuleTixs :: TixModule -> [Integer] +tixModuleTixs (TixModule _ _ _ tixs) = tixs + +-- We /always/ read and write Tix from the current working directory. + +-- read a Tix File. +readTix :: String + -> IO (Maybe Tix) +readTix tix_filename = + catch (do contents <- readFile $ tix_filename + return $ Just $ read contents) + (\ _ -> return $ Nothing) + +-- write a Tix File. +writeTix :: String + -> Tix + -> IO () +writeTix name tix = + writeFile name (show tix) + +{- +tixName :: String -> String +tixName name = name ++ ".tix" +-} + +-- getTixFullName takes a binary or .tix-file name, +-- and normalizes it into a .tix-file name. +getTixFileName :: String -> String +getTixFileName str | ".tix" `isSuffixOf` str + = str + | otherwise + = str ++ ".tix" + diff --git a/Trace/Hpc/Util.hs b/Trace/Hpc/Util.hs new file mode 100644 --- /dev/null +++ b/Trace/Hpc/Util.hs @@ -0,0 +1,105 @@ +----------------------------------------- +-- Andy Gill and Colin Runciman, June 2006 +------------------------------------------ + +-- | Minor utilities for the HPC tools. + +module Trace.Hpc.Util + ( HpcPos + , fromHpcPos + , toHpcPos + , insideHpcPos + , HpcHash(..) + , Hash + ) where + +import Data.List(foldl') +import Data.Char (ord) +import Data.Bits (xor) +import Data.Word + +-- | 'HpcPos' is an Hpc local rendition of a Span. +data HpcPos = P !Int !Int !Int !Int deriving (Eq, Ord) + +-- | 'fromHpcPos' explodes the HpcPos into line:column-line:colunm +fromHpcPos :: HpcPos -> (Int,Int,Int,Int) +fromHpcPos (P l1 c1 l2 c2) = (l1,c1,l2,c2) + +-- | 'toHpcPos' implodes to HpcPos, from line:column-line:colunm +toHpcPos :: (Int,Int,Int,Int) -> HpcPos +toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2 + +-- | asks the question, is the first argument inside the second argument. +insideHpcPos :: HpcPos -> HpcPos -> Bool +insideHpcPos small big = + sl1 >= bl1 && + (sl1 /= bl1 || sc1 >= bc1) && + sl2 <= bl2 && + (sl2 /= bl2 || sc2 <= bc2) + where (sl1,sc1,sl2,sc2) = fromHpcPos small + (bl1,bc1,bl2,bc2) = fromHpcPos big + +instance Show HpcPos where + show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2 + +instance Read HpcPos where + readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)] + where + (before,after) = span (/= ',') pos + (lhs0,rhs0) = case span (/= '-') before of + (lhs,'-':rhs) -> (lhs,rhs) + (lhs,"") -> (lhs,lhs) + _ -> error "bad parse" + (l1,':':c1) = span (/= ':') lhs0 + (l2,':':c2) = span (/= ':') rhs0 + +------------------------------------------------------------------------------ + +-- Very simple Hash number generators + +class HpcHash a where + toHash :: a -> Hash + +newtype Hash = Hash Word32 deriving (Eq) + +instance Read Hash where + readsPrec p n = [ (Hash v,rest) + | (v,rest) <- readsPrec p n + ] + +instance Show Hash where + showsPrec p (Hash n) = showsPrec p n + +instance Num Hash where + (Hash a) + (Hash b) = Hash $ a + b + (Hash a) * (Hash b) = Hash $ a * b + (Hash a) - (Hash b) = Hash $ a - b + negate (Hash a) = Hash $ negate a + abs (Hash a) = Hash $ abs a + signum (Hash a) = Hash $ signum a + fromInteger n = Hash $ fromInteger n + +instance HpcHash Int where + toHash n = Hash $ fromIntegral n + +instance HpcHash Integer where + toHash n = fromInteger n + +instance HpcHash Char where + toHash c = Hash $ fromIntegral $ ord c + +instance HpcHash Bool where + toHash True = 1 + toHash False = 0 + +instance HpcHash a => HpcHash [a] where + toHash xs = foldl' (\ h c -> toHash c `hxor` (h * 33)) 5381 xs + +instance (HpcHash a,HpcHash b) => HpcHash (a,b) where + toHash (a,b) = toHash a * 33 `hxor` toHash b + +instance HpcHash HpcPos where + toHash (P a b c d) = Hash $ fromIntegral $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d + +hxor :: Hash -> Hash -> Hash +hxor (Hash x) (Hash y) = Hash $ x `xor` y diff --git a/hpc.cabal b/hpc.cabal new file mode 100644 --- /dev/null +++ b/hpc.cabal @@ -0,0 +1,17 @@ +name: hpc +version: 0.5.0.0 +license: BSD3 +license-file: LICENSE +author: Andy Gill +maintainer: libraries@haskell.org +category: Control +synopsis: Code Coverage Library for Haskell +build-type: Simple +ghc-options: -Wall +exposed-modules: + Trace.Hpc.Util, + Trace.Hpc.Mix, + Trace.Hpc.Tix, + Trace.Hpc.Reflect +build-depends: base, directory, old-time, containers +extensions: CPP