hpc (empty) → 0.5.0.0

raw patch · 7 files changed

+482/−0 lines, 7 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, old-time

Files

• LICENSE +25/−0
• Setup.hs +6/−0
• Trace/Hpc/Mix.hs +192/−0
• Trace/Hpc/Reflect.hsc +75/−0
• Trace/Hpc/Tix.hs +62/−0
• Trace/Hpc/Util.hs +105/−0
• hpc.cabal +17/−0

@@ -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.

@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain

@@ -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

@@ -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 ()

@@ -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"+

@@ -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

@@ -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