diff options
Diffstat (limited to 'compiler/utils')
| -rw-r--r-- | compiler/utils/Binary.hs | 26 | ||||
| -rw-r--r-- | compiler/utils/Digraph.lhs | 88 | ||||
| -rw-r--r-- | compiler/utils/Fingerprint.hsc | 59 | ||||
| -rw-r--r-- | compiler/utils/FiniteMap.lhs | 1 | ||||
| -rw-r--r-- | compiler/utils/Outputable.lhs | 18 | ||||
| -rw-r--r-- | compiler/utils/Panic.lhs | 10 | ||||
| -rw-r--r-- | compiler/utils/UniqFM.lhs | 3 | ||||
| -rw-r--r-- | compiler/utils/Util.lhs | 6 | ||||
| -rw-r--r-- | compiler/utils/md5.c | 3 |
9 files changed, 179 insertions, 35 deletions
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index c5a2c8f4fd..b61b2838ee 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -30,7 +30,9 @@ module Binary writeBinMem, readBinMem, + fingerprintBinMem, + computeFingerprint, isEOFBin, @@ -74,6 +76,9 @@ import Data.Array import Data.IORef import Data.Char ( ord, chr ) import Data.Typeable +#if __GLASGOW_HASKELL__ >= 701 +import Data.Typeable.Internal +#endif import Control.Monad ( when ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -237,6 +242,18 @@ fingerprintBinMem (BinMem _ ix_r _ arr_r) = do ix <- readFastMutInt ix_r withForeignPtr arr $ \p -> fingerprintData p ix +computeFingerprint :: Binary a + => (BinHandle -> Name -> IO ()) + -> a + -> IO Fingerprint + +computeFingerprint put_name a = do + bh <- openBinMem (3*1024) -- just less than a block + ud <- newWriteState put_name putFS + bh <- return $ setUserData bh ud + put_ bh a + fingerprintBinMem bh + -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () expandBin (BinMem _ _ sz_r arr_r) off = do @@ -562,6 +579,14 @@ instance Binary (Bin a) where -- ----------------------------------------------------------------------------- -- Instances for Data.Typeable stuff +#if __GLASGOW_HASKELL__ >= 701 +instance Binary TyCon where + put_ bh (TyCon _ p m n) = do + put_ bh (p,m,n) + get bh = do + (p,m,n) <- get bh + return (mkTyCon3 p m n) +#else instance Binary TyCon where put_ bh ty_con = do let s = tyConString ty_con @@ -569,6 +594,7 @@ instance Binary TyCon where get bh = do s <- get bh return (mkTyCon s) +#endif instance Binary TypeRep where put_ bh type_rep = do diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index a341bdecbc..b9d2da37d2 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -3,10 +3,11 @@ % \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, - SCC(..), flattenSCC, flattenSCCs, + SCC(..), Node, flattenSCC, flattenSCCs, stronglyConnCompG, topologicalSortG, verticesG, edgesG, hasVertexG, reachableG, transposeG, @@ -14,6 +15,8 @@ module Digraph( vertexGroupsG, emptyG, componentsG, + findCycle, + -- For backwards compatability with the simpler version of Digraph stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR, @@ -37,7 +40,7 @@ module Digraph( ------------------------------------------------------------------------------ -import Util ( sortLe ) +import Util ( sortLe, minWith, count ) import Outputable import Maybes ( expectJust ) import MonadUtils ( allM ) @@ -51,6 +54,8 @@ import Data.Maybe import Data.Array import Data.List ( (\\) ) import Data.Array.ST +import qualified Data.Map as Map +import qualified Data.Set as Set \end{code} %************************************************************************ @@ -78,6 +83,13 @@ data Graph node = Graph { data Edge node = Edge node node +type Node key payload = (payload, key, [key]) + -- The payload is user data, just carried around in this module + -- The keys are ordered + -- The [key] are the dependencies of the node; + -- it's ok to have extra keys in the dependencies that + -- are not the key of any Node in the graph + emptyGraph :: Graph a emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) @@ -101,10 +113,10 @@ graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vert graphFromEdgedVertices :: Ord key - => [(node, key, [key])] -- The graph; its ok for the + => [Node key payload] -- The graph; its ok for the -- out-list to contain keys which arent -- a vertex key, they are ignored - -> Graph (node, key, [key]) + -> Graph (Node key payload) graphFromEdgedVertices [] = emptyGraph graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor) where key_extractor (_, k, _) = k @@ -147,6 +159,63 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte %************************************************************************ \begin{code} +type WorkItem key payload + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a + +-- | Find a reasonably short cycle a->b->c->a, in a strongly +-- connected component. The input nodes are presumed to be +-- a SCC, so you can start anywhere. +findCycle :: forall payload key. Ord key + => [Node key payload] -- The nodes. The dependencies can + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next +findCycle graph + = go Set.empty (new_work root_deps []) [] + where + env :: Map.Map key (Node key payload) + env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ] + + -- Find the node with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + root :: Node key payload + root = fst (minWith snd [ (node, count (`Map.member` env) deps) + | node@(_,_,deps) <- graph ]) + (root_payload,root_key,root_deps) = root + + + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((payload,key,deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) + + new_work :: [key] -> [payload] -> [WorkItem key payload] + new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] +\end{code} + +%************************************************************************ +%* * +%* SCC +%* * +%************************************************************************ + +\begin{code} data SCC vertex = AcyclicSCC vertex | CyclicSCC [vertex] @@ -164,6 +233,9 @@ flattenSCC (CyclicSCC vs) = vs instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) +instance PlatformOutputable a => PlatformOutputable (SCC a) where + pprPlatform platform (AcyclicSCC v) = text "NONREC" $$ (nest 3 (pprPlatform platform v)) + pprPlatform platform (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map (pprPlatform platform) vs))) \end{code} %************************************************************************ @@ -191,8 +263,8 @@ stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } -- The following two versions are provided for backwards compatability: stronglyConnCompFromEdgedVertices :: Ord key - => [(node, key, [key])] - -> [SCC node] + => [Node key payload] + -> [SCC payload] stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR where get_node (n, _, _) = n @@ -200,8 +272,8 @@ stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEd -- the (some of) the result of SCC, so you dont want to lose the dependency info stronglyConnCompFromEdgedVerticesR :: Ord key - => [(node, key, [key])] - -> [SCC (node, key, [key])] + => [Node key payload] + -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices \end{code} diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc index 20b3ee9da4..735bf23628 100644 --- a/compiler/utils/Fingerprint.hsc +++ b/compiler/utils/Fingerprint.hsc @@ -9,9 +9,10 @@ -- ---------------------------------------------------------------------------- module Fingerprint ( - Fingerprint(..), fingerprint0, + Fingerprint(..), fingerprint0, readHexFingerprint, - fingerprintData + fingerprintData, + fingerprintString ) where #include "md5.h" @@ -19,11 +20,20 @@ module Fingerprint ( import Outputable -import Foreign -import Foreign.C import Text.Printf import Numeric ( readHex ) +##if __GLASGOW_HASKELL__ >= 701 +-- The MD5 implementation is now in base, to support Typeable +import GHC.Fingerprint +##endif + +##if __GLASGOW_HASKELL__ < 701 +import Data.Char +import Foreign +import Foreign.C +import GHC.IO (unsafeDupablePerformIO) + -- Using 128-bit MD5 fingerprints for now. data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 @@ -33,19 +43,6 @@ data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 fingerprint0 :: Fingerprint fingerprint0 = Fingerprint 0 0 -instance Outputable Fingerprint where - ppr (Fingerprint w1 w2) = text (printf "%016x%016x" i1 i2) - where i1 = fromIntegral w1 :: Integer - i2 = fromIntegral w2 :: Integer - -- printf in GHC 6.4.2 didn't have Word64 instances - --- useful for parsing the output of 'md5sum', should we want to do that. -readHexFingerprint :: String -> Fingerprint -readHexFingerprint s = Fingerprint w1 w2 - where (s1,s2) = splitAt 16 s - [(w1,"")] = readHex s1 - [(w2,"")] = readHex (take 16 s2) - peekFingerprint :: Ptr Word8 -> IO Fingerprint peekFingerprint p = do let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64 @@ -69,6 +66,19 @@ fingerprintData buf len = do c_MD5Final pdigest pctxt peekFingerprint (castPtr pdigest) +-- This is duplicated in libraries/base/GHC/Fingerprint.hs +fingerprintString :: String -> Fingerprint +fingerprintString str = unsafeDupablePerformIO $ + withArrayLen word8s $ \len p -> + fingerprintData p len + where word8s = concatMap f str + f c = let w32 :: Word32 + w32 = fromIntegral (ord c) + in [fromIntegral (w32 `shiftR` 24), + fromIntegral (w32 `shiftR` 16), + fromIntegral (w32 `shiftR` 8), + fromIntegral w32] + data MD5Context foreign import ccall unsafe "MD5Init" @@ -77,3 +87,18 @@ foreign import ccall unsafe "MD5Update" c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO () foreign import ccall unsafe "MD5Final" c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO () +##endif + +instance Outputable Fingerprint where + ppr (Fingerprint w1 w2) = text (printf "%016x%016x" i1 i2) + where i1 = fromIntegral w1 :: Integer + i2 = fromIntegral w2 :: Integer + -- printf in GHC 6.4.2 didn't have Word64 instances + +-- useful for parsing the output of 'md5sum', should we want to do that. +readHexFingerprint :: String -> Fingerprint +readHexFingerprint s = Fingerprint w1 w2 + where (s1,s2) = splitAt 16 s + [(w1,"")] = readHex s1 + [(w2,"")] = readHex (take 16 s2) + diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs index 3acadf137c..94d1eef94e 100644 --- a/compiler/utils/FiniteMap.lhs +++ b/compiler/utils/FiniteMap.lhs @@ -1,3 +1,4 @@ +Some extra functions to extend Data.Map \begin{code} module FiniteMap ( diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 713866bfc2..be6a9cf84d 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -13,6 +13,7 @@ module Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), + PlatformOutputable(..), -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, @@ -74,6 +75,7 @@ import {-# SOURCE #-} OccName( OccName ) import StaticFlags import FastString import FastTypes +import Platform import qualified Pretty import Pretty ( Doc, Mode(..) ) import Panic @@ -603,6 +605,13 @@ class Outputable a where ppr = pprPrec 0 pprPrec _ = ppr + +class PlatformOutputable a where + pprPlatform :: Platform -> a -> SDoc + pprPlatformPrec :: Platform -> Rational -> a -> SDoc + + pprPlatform platform = pprPlatformPrec platform 0 + pprPlatformPrec platform _ = pprPlatform platform \end{code} \begin{code} @@ -624,12 +633,19 @@ instance Outputable Word where instance Outputable () where ppr _ = text "()" +instance PlatformOutputable () where + pprPlatform _ _ = text "()" instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) +instance (PlatformOutputable a) => PlatformOutputable [a] where + pprPlatform platform xs = brackets (fsep (punctuate comma (map (pprPlatform platform) xs))) instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) +instance (PlatformOutputable a, PlatformOutputable b) => PlatformOutputable (a, b) where + pprPlatform platform (x,y) + = parens (sep [pprPlatform platform x <> comma, pprPlatform platform y]) instance Outputable a => Outputable (Maybe a) where ppr Nothing = ptext (sLit "Nothing") @@ -690,6 +706,8 @@ instance Outputable FastString where instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) +instance (PlatformOutputable key, PlatformOutputable elt) => PlatformOutputable (M.Map key elt) where + pprPlatform platform m = pprPlatform platform (M.toList m) instance (Outputable elt) => Outputable (IM.IntMap elt) where ppr m = ppr (IM.toList m) \end{code} diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index d430df695e..1fd815604c 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -78,7 +78,7 @@ data GhcException -- | An error in the user's code, probably. | ProgramError String - deriving Eq + deriving (Typeable, Eq) instance Exception GhcException @@ -87,9 +87,6 @@ instance Show GhcException where showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e showsPrec _ e = showString progName . showString ": " . showGhcException e -instance Typeable GhcException where - typeOf _ = mkTyConApp ghcExceptionTc [] - -- | The name of this GHC. progName :: String @@ -154,11 +151,6 @@ handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a handleGhcException = ghandle -ghcExceptionTc :: TyCon -ghcExceptionTc = mkTyCon "GhcException" -{-# NOINLINE ghcExceptionTc #-} - - -- | Panics and asserts. panic, sorry, pgmError :: String -> a panic x = throwGhcException (Panic x) diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 9c9fdc9bc4..7cbc3dbcfb 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -67,6 +67,8 @@ import Compiler.Hoopl hiding (Unique) import Data.Function (on) import qualified Data.IntMap as M import qualified Data.Foldable as Foldable +import Data.Typeable +import Data.Data \end{code} %************************************************************************ @@ -164,6 +166,7 @@ ufmToList :: UniqFM elt -> [(Unique, elt)] \begin{code} newtype UniqFM ele = UFM { unUFM :: M.IntMap ele } + deriving (Typeable,Data) instance Eq ele => Eq (UniqFM ele) where (==) = (==) `on` unUFM diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index dc4f32ec5e..ea46b28334 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -41,7 +41,7 @@ module Util ( nTimes, -- * Sorting - sortLe, sortWith, on, + sortLe, sortWith, minWith, on, -- * Comparisons isEqual, eqListBy, @@ -543,6 +543,10 @@ sortWith get_key xs = sortLe le xs where x `le` y = get_key x < get_key y +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs) + on :: (a -> a -> c) -> (b -> a) -> b -> b -> c on cmp sel = \x y -> sel x `cmp` sel y diff --git a/compiler/utils/md5.c b/compiler/utils/md5.c index 0570cbbdf1..06c2d37738 100644 --- a/compiler/utils/md5.c +++ b/compiler/utils/md5.c @@ -15,6 +15,8 @@ * will fill a supplied 16-byte array with the digest. */ +#if __GLASGOW_HASKELL__ < 701 + #include "HsFFI.h" #include "md5.h" #include <string.h> @@ -236,3 +238,4 @@ MD5Transform(word32 buf[4], word32 const in[16]) buf[3] += d; } +#endif |