diff options
Diffstat (limited to 'compiler/utils')
| -rw-r--r-- | compiler/utils/Bag.lhs | 2 | ||||
| -rw-r--r-- | compiler/utils/Binary.hs | 198 | ||||
| -rw-r--r-- | compiler/utils/BooleanFormula.hs | 211 | ||||
| -rw-r--r-- | compiler/utils/BufWrite.hs | 2 | ||||
| -rw-r--r-- | compiler/utils/Digraph.lhs | 32 | ||||
| -rw-r--r-- | compiler/utils/Encoding.hs | 3 | ||||
| -rw-r--r-- | compiler/utils/ExtsCompat46.hs | 293 | ||||
| -rw-r--r-- | compiler/utils/FastMutInt.lhs | 16 | ||||
| -rw-r--r-- | compiler/utils/FastString.lhs | 285 | ||||
| -rw-r--r-- | compiler/utils/FastTypes.lhs | 12 | ||||
| -rw-r--r-- | compiler/utils/Fingerprint.hsc | 45 | ||||
| -rw-r--r-- | compiler/utils/FiniteMap.lhs | 4 | ||||
| -rw-r--r-- | compiler/utils/GraphBase.hs | 2 | ||||
| -rw-r--r-- | compiler/utils/GraphPpr.hs | 2 | ||||
| -rw-r--r-- | compiler/utils/IOEnv.hs | 11 | ||||
| -rw-r--r-- | compiler/utils/Maybes.lhs | 66 | ||||
| -rw-r--r-- | compiler/utils/OrdList.lhs | 9 | ||||
| -rw-r--r-- | compiler/utils/Outputable.lhs | 95 | ||||
| -rw-r--r-- | compiler/utils/Platform.hs | 15 | ||||
| -rw-r--r-- | compiler/utils/Pretty.lhs | 54 | ||||
| -rw-r--r-- | compiler/utils/Stream.hs | 13 | ||||
| -rw-r--r-- | compiler/utils/UnVarGraph.hs | 136 | ||||
| -rw-r--r-- | compiler/utils/UniqFM.lhs | 51 | ||||
| -rw-r--r-- | compiler/utils/UniqSet.lhs | 15 | ||||
| -rw-r--r-- | compiler/utils/Util.lhs | 31 |
25 files changed, 1269 insertions, 334 deletions
diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs index a83397898e..2d823e46bb 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.lhs @@ -21,8 +21,6 @@ module Bag ( mapAndUnzipBagM, mapAccumBagLM ) where -#include "Typeable.h" - import Outputable import Util diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index e07577776a..332bfc8e0c 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -20,7 +20,6 @@ module Binary {-type-} BinHandle, SymbolTable, Dictionary, - openBinIO, openBinIO_, openBinMem, -- closeBin, @@ -87,7 +86,7 @@ import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) ) -import GHC.Exts +import ExtsCompat46 import GHC.Word ( Word8(..) ) import GHC.IO ( IO(..) ) @@ -108,15 +107,6 @@ data BinHandle -- XXX: should really store a "high water mark" for dumping out -- the binary data to a file. - | BinIO { -- binary data stored in a file - bh_usr :: UserData, - _off_r :: !FastMutInt, -- the current offset (cached) - _hdl :: !IO.Handle -- the file handle (must be seekable) - } - -- cache the file ptr in BinIO; using hTell is too expensive - -- to call repeatedly. If anyone else is modifying this Handle - -- at the same time, we'll be screwed. - getUserData :: BinHandle -> UserData getUserData bh = bh_usr bh @@ -155,15 +145,6 @@ putAt bh p x = do seekBin bh p; put_ bh x; return () getAt :: Binary a => BinHandle -> Bin a -> IO a getAt bh p = do seekBin bh p; get bh -openBinIO_ :: IO.Handle -> IO BinHandle -openBinIO_ h = openBinIO h - -openBinIO :: IO.Handle -> IO BinHandle -openBinIO h = do - r <- newFastMutInt - writeFastMutInt r 0 - return (BinIO noUserData r h) - openBinMem :: Int -> IO BinHandle openBinMem size | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" @@ -177,13 +158,9 @@ openBinMem size return (BinMem noUserData ix_r sz_r arr_r) tellBin :: BinHandle -> IO (Bin a) -tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) seekBin :: BinHandle -> Bin a -> IO () -seekBin (BinIO _ ix_r h) (BinPtr p) = do - writeFastMutInt ix_r p - hSeek h AbsoluteSeek (fromIntegral p) seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do sz <- readFastMutInt sz_r if (p >= sz) @@ -191,11 +168,6 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do else writeFastMutInt ix_r p seekBy :: BinHandle -> Int -> IO () -seekBy (BinIO _ ix_r h) off = do - ix <- readFastMutInt ix_r - let ix' = ix + off - writeFastMutInt ix_r ix' - hSeek h AbsoluteSeek (fromIntegral ix') seekBy h@(BinMem _ ix_r sz_r _) off = do sz <- readFastMutInt sz_r ix <- readFastMutInt ix_r @@ -209,10 +181,8 @@ isEOFBin (BinMem _ ix_r sz_r _) = do ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r return (ix >= sz) -isEOFBin (BinIO _ _ h) = hIsEOF h writeBinMem :: BinHandle -> FilePath -> IO () -writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle" writeBinMem (BinMem _ ix_r _ arr_r) fn = do h <- openBinaryFile fn WriteMode arr <- readIORef arr_r @@ -239,7 +209,6 @@ readBinMem filename = do return (BinMem noUserData ix_r sz_r arr_r) fingerprintBinMem :: BinHandle -> IO Fingerprint -fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle" fingerprintBinMem (BinMem _ ix_r _ arr_r) = do arr <- readIORef arr_r ix <- readFastMutInt ix_r @@ -265,11 +234,9 @@ expandBin (BinMem _ _ sz_r arr_r) off = do arr' <- mallocForeignPtrBytes sz' withForeignPtr arr $ \old -> withForeignPtr arr' $ \new -> - copyBytes new old sz + copyBytes new old sz writeFastMutInt sz_r sz' writeIORef arr_r arr' -expandBin (BinIO _ _ _) _ = return () --- no need to expand a file, we'll assume they expand by themselves. -- ----------------------------------------------------------------------------- -- Low-level reading/writing of bytes @@ -286,11 +253,6 @@ putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do withForeignPtr arr $ \p -> pokeByteOff p ix w writeFastMutInt ix_r (ix+1) return () -putWord8 (BinIO _ ix_r h) w = do - ix <- readFastMutInt ix_r - hPutChar h (chr (fromIntegral w)) -- XXX not really correct - writeFastMutInt ix_r (ix+1) - return () getWord8 :: BinHandle -> IO Word8 getWord8 (BinMem _ ix_r sz_r arr_r) = do @@ -302,11 +264,6 @@ getWord8 (BinMem _ ix_r sz_r arr_r) = do w <- withForeignPtr arr $ \p -> peekByteOff p ix writeFastMutInt ix_r (ix+1) return w -getWord8 (BinIO _ ix_r h) = do - ix <- readFastMutInt ix_r - c <- hGetChar h - writeFastMutInt ix_r (ix+1) - return $! (fromIntegral (ord c)) -- XXX not really correct putByte :: BinHandle -> Word8 -> IO () putByte bh w = put_ bh w @@ -639,7 +596,11 @@ lazyGet :: Binary a => BinHandle -> IO a lazyGet bh = do p <- get bh -- a BinPtr p_a <- tellBin bh - a <- unsafeInterleaveIO (getAt bh p_a) + a <- unsafeInterleaveIO $ do + -- NB: Use a fresh off_r variable in the child thread, for thread + -- safety. + off_r <- newFastMutInt + getAt bh { _off_r = off_r } p_a seekBin bh p -- skip over the object for now return a @@ -667,8 +628,8 @@ newReadState get_name get_fs ud_put_name = undef "put_name", ud_put_fs = undef "put_fs" } - -newWriteState :: (BinHandle -> Name -> IO ()) + +newWriteState :: (BinHandle -> Name -> IO ()) -> (BinHandle -> FastString -> IO ()) -> UserData newWriteState put_name put_fs @@ -784,3 +745,144 @@ instance Binary FunctionOrData where 1 -> return IsData _ -> panic "Binary FunctionOrData" +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh ConstraintTuple = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return BoxedTuple + 1 -> do return UnboxedTuple + _ -> do return ConstraintTuple + +instance Binary Activation where + put_ bh NeverActive = do + putByte bh 0 + put_ bh AlwaysActive = do + putByte bh 1 + put_ bh (ActiveBefore aa) = do + putByte bh 2 + put_ bh aa + put_ bh (ActiveAfter ab) = do + putByte bh 3 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do return NeverActive + 1 -> do return AlwaysActive + 2 -> do aa <- get bh + return (ActiveBefore aa) + _ -> do ab <- get bh + return (ActiveAfter ab) + +instance Binary InlinePragma where + put_ bh (InlinePragma a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + + get bh = do + a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (InlinePragma a b c d) + +instance Binary RuleMatchInfo where + put_ bh FunLike = putByte bh 0 + put_ bh ConLike = putByte bh 1 + get bh = do + h <- getByte bh + if h == 1 then return ConLike + else return FunLike + +instance Binary InlineSpec where + put_ bh EmptyInlineSpec = putByte bh 0 + put_ bh Inline = putByte bh 1 + put_ bh Inlinable = putByte bh 2 + put_ bh NoInline = putByte bh 3 + + get bh = do h <- getByte bh + case h of + 0 -> return EmptyInlineSpec + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline + +instance Binary DefMethSpec where + put_ bh NoDM = putByte bh 0 + put_ bh VanillaDM = putByte bh 1 + put_ bh GenericDM = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return NoDM + 1 -> return VanillaDM + _ -> return GenericDM + +instance Binary RecFlag where + put_ bh Recursive = do + putByte bh 0 + put_ bh NonRecursive = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return Recursive + _ -> do return NonRecursive + +instance Binary OverlapFlag where + put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b + put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b + put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b + get bh = do + h <- getByte bh + b <- get bh + case h of + 0 -> return $ NoOverlap b + 1 -> return $ OverlapOk b + 2 -> return $ Incoherent b + _ -> panic ("get OverlapFlag " ++ show h) + +instance Binary FixityDirection where + put_ bh InfixL = do + putByte bh 0 + put_ bh InfixR = do + putByte bh 1 + put_ bh InfixN = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return InfixL + 1 -> do return InfixR + _ -> do return InfixN + +instance Binary Fixity where + put_ bh (Fixity aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (Fixity aa ab) + +instance Binary WarningTxt where + put_ bh (WarningTxt w) = do + putByte bh 0 + put_ bh w + put_ bh (DeprecatedTxt d) = do + putByte bh 1 + put_ bh d + + get bh = do + h <- getByte bh + case h of + 0 -> do w <- get bh + return (WarningTxt w) + _ -> do d <- get bh + return (DeprecatedTxt d) + diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs new file mode 100644 index 0000000000..8620ef555d --- /dev/null +++ b/compiler/utils/BooleanFormula.hs @@ -0,0 +1,211 @@ +-------------------------------------------------------------------------------- +-- | Boolean formulas without quantifiers and without negation. +-- Such a formula consists of variables, conjunctions (and), and disjunctions (or). +-- +-- This module is used to represent minimal complete definitions for classes. +-- +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} + +module BooleanFormula ( + BooleanFormula(..), + mkFalse, mkTrue, mkAnd, mkOr, mkVar, + isFalse, isTrue, + eval, simplify, isUnsatisfied, + implies, impliesAtom, + pprBooleanFormula, pprBooleanFormulaNice + ) where + +import Data.List ( nub, intersperse ) +import Data.Data +import Data.Foldable ( Foldable ) +import Data.Traversable ( Traversable ) + +import MonadUtils +import Outputable +import Binary + +---------------------------------------------------------------------- +-- Boolean formula type and smart constructors +---------------------------------------------------------------------- + +data BooleanFormula a = Var a | And [BooleanFormula a] | Or [BooleanFormula a] + deriving (Eq, Data, Typeable, Functor, Foldable, Traversable) + +mkVar :: a -> BooleanFormula a +mkVar = Var + +mkFalse, mkTrue :: BooleanFormula a +mkFalse = Or [] +mkTrue = And [] + +-- Convert a Bool to a BooleanFormula +mkBool :: Bool -> BooleanFormula a +mkBool False = mkFalse +mkBool True = mkTrue + +-- Make a conjunction, and try to simplify +mkAnd :: Eq a => [BooleanFormula a] -> BooleanFormula a +mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd + where + -- See Note [Simplification of BooleanFormulas] + fromAnd :: BooleanFormula a -> Maybe [BooleanFormula a] + fromAnd (And xs) = Just xs + -- assume that xs are already simplified + -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs + fromAnd (Or []) = Nothing -- in case of False we bail out, And [..,mkFalse,..] == mkFalse + fromAnd x = Just [x] + mkAnd' [x] = x + mkAnd' xs = And xs + +mkOr :: Eq a => [BooleanFormula a] -> BooleanFormula a +mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr + where + -- See Note [Simplification of BooleanFormulas] + fromOr (Or xs) = Just xs + fromOr (And []) = Nothing + fromOr x = Just [x] + mkOr' [x] = x + mkOr' xs = Or xs + + +{- +Note [Simplification of BooleanFormulas] +~~~~~~~~~~~~~~~~~~~~~~ +The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, + 1. Collapsing nested ands and ors, so + `(mkAnd [x, And [y,z]]` + is represented as + `And [x,y,z]` + Implemented by `fromAnd`/`fromOr` + 2. Collapsing trivial ands and ors, so + `mkAnd [x]` becomes just `x`. + Implemented by mkAnd' / mkOr' + 3. Conjunction with false, disjunction with true is simplified, i.e. + `mkAnd [mkFalse,x]` becomes `mkFalse`. + 4. Common subexpresion elimination: + `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. + +This simplification is not exhaustive, in the sense that it will not produce +the smallest possible equivalent expression. For example, +`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently +is not. A general simplifier would need to use something like BDDs. + +The reason behind the (crude) simplifier is to make for more user friendly +error messages. E.g. for the code + > class Foo a where + > {-# MINIMAL bar, (foo, baq | foo, quux) #-} + > instance Foo Int where + > bar = ... + > baz = ... + > quux = ... +We don't show a ridiculous error message like + Implement () and (either (`foo' and ()) or (`foo' and ())) +-} + +---------------------------------------------------------------------- +-- Evaluation and simplification +---------------------------------------------------------------------- + +isFalse :: BooleanFormula a -> Bool +isFalse (Or []) = True +isFalse _ = False + +isTrue :: BooleanFormula a -> Bool +isTrue (And []) = True +isTrue _ = False + +eval :: (a -> Bool) -> BooleanFormula a -> Bool +eval f (Var x) = f x +eval f (And xs) = all (eval f) xs +eval f (Or xs) = any (eval f) xs + +-- Simplify a boolean formula. +-- The argument function should give the truth of the atoms, or Nothing if undecided. +simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a +simplify f (Var a) = case f a of + Nothing -> Var a + Just b -> mkBool b +simplify f (And xs) = mkAnd (map (simplify f) xs) +simplify f (Or xs) = mkOr (map (simplify f) xs) + +-- Test if a boolean formula is satisfied when the given values are assigned to the atoms +-- if it is, returns Nothing +-- if it is not, return (Just remainder) +isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) +isUnsatisfied f bf + | isTrue bf' = Nothing + | otherwise = Just bf' + where + f' x = if f x then Just True else Nothing + bf' = simplify f' bf + +-- prop_simplify: +-- eval f x == True <==> isTrue (simplify (Just . f) x) +-- eval f x == False <==> isFalse (simplify (Just . f) x) + +-- If the boolean formula holds, does that mean that the given atom is always true? +impliesAtom :: Eq a => BooleanFormula a -> a -> Bool +Var x `impliesAtom` y = x == y +And xs `impliesAtom` y = any (`impliesAtom` y) xs -- we have all of xs, so one of them implying y is enough +Or xs `impliesAtom` y = all (`impliesAtom` y) xs + +implies :: Eq a => BooleanFormula a -> BooleanFormula a -> Bool +x `implies` Var y = x `impliesAtom` y +x `implies` And ys = all (x `implies`) ys +x `implies` Or ys = any (x `implies`) ys + +---------------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------------- + +-- Pretty print a BooleanFormula, +-- using the arguments as pretty printers for Var, And and Or respectively +pprBooleanFormula' :: (Rational -> a -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula' pprVar pprAnd pprOr = go + where + go p (Var x) = pprVar p x + go p (And []) = cparen (p > 0) $ empty + go p (And xs) = pprAnd p (map (go 3) xs) + go _ (Or []) = keyword $ text "FALSE" + go p (Or xs) = pprOr p (map (go 2) xs) + +-- Pretty print in source syntax, "a | b | c,d,e" +pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr + where + pprAnd p = cparen (p > 3) . fsep . punctuate comma + pprOr p = cparen (p > 2) . fsep . intersperse (text "|") + +-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? +pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc +pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 + where + pprVar _ = quotes . ppr + pprAnd p = cparen (p > 1) . pprAnd' + pprAnd' [] = empty + pprAnd' [x,y] = x <+> text "and" <+> y + pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs + pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) + +instance Outputable a => Outputable (BooleanFormula a) where + pprPrec = pprBooleanFormula pprPrec + +---------------------------------------------------------------------- +-- Binary +---------------------------------------------------------------------- + +instance Binary a => Binary (BooleanFormula a) where + put_ bh (Var x) = putByte bh 0 >> put_ bh x + put_ bh (And xs) = putByte bh 1 >> put_ bh xs + put_ bh (Or xs) = putByte bh 2 >> put_ bh xs + + get bh = do + h <- getByte bh + case h of + 0 -> Var <$> get bh + 1 -> And <$> get bh + _ -> Or <$> get bh diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs index c0dda03bbb..f85ea8e792 100644 --- a/compiler/utils/BufWrite.hs +++ b/compiler/utils/BufWrite.hs @@ -14,7 +14,7 @@ -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details module BufWrite ( diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index 9ae84a7897..cc684303b6 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -7,7 +7,7 @@ -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details {-# LANGUAGE ScopedTypeVariables #-} @@ -15,7 +15,8 @@ module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, SCC(..), Node, flattenSCC, flattenSCCs, - stronglyConnCompG, topologicalSortG, dfsTopSortG, + stronglyConnCompG, stronglyConnCompFromG, + topologicalSortG, dfsTopSortG, verticesG, edgesG, hasVertexG, reachableG, transposeG, outdegreeG, indegreeG, @@ -254,9 +255,21 @@ edges going from them to earlier ones. \begin{code} stronglyConnCompG :: Graph node -> [SCC node] -stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn }) = map decode forest +stronglyConnCompG graph = decodeSccs graph forest + where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) + +-- Find the set of strongly connected components starting from the +-- given roots. This is a good way to discard unreachable nodes at +-- the same time as computing SCCs. +stronglyConnCompFromG :: Graph node -> [node] -> [SCC node] +stronglyConnCompFromG graph roots = decodeSccs graph forest + where forest = {-# SCC "Digraph.scc" #-} sccFrom (gr_int_graph graph) vs + vs = [ v | Just v <- map (gr_node_to_vertex graph) roots ] + +decodeSccs :: Graph node -> Forest Vertex -> [SCC node] +decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest + = map decode forest where - forest = {-# SCC "Digraph.scc" #-} scc graph decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] | otherwise = AcyclicSCC (vertex_fn v) decode other = CyclicSCC (dec other []) @@ -269,11 +282,12 @@ stronglyConnCompFromEdgedVertices :: Ord key => [Node key payload] -> [SCC payload] -stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR +stronglyConnCompFromEdgedVertices + = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR where get_node (n, _, _) = n -- The "R" interface is used when you expect to apply SCC to --- the (some of) the result of SCC, so you dont want to lose the dependency info +-- (some of) the result of SCC, so you dont want to lose the dependency info stronglyConnCompFromEdgedVerticesR :: Ord key => [Node key payload] @@ -534,6 +548,9 @@ postorderF ts = foldr (.) id $ map postorder ts postOrd :: IntGraph -> [Vertex] postOrd g = postorderF (dff g) [] +postOrdFrom :: IntGraph -> [Vertex] -> [Vertex] +postOrdFrom g vs = postorderF (dfs g vs) [] + topSort :: IntGraph -> [Vertex] topSort = reverse . postOrd \end{code} @@ -557,6 +574,9 @@ undirected g = buildG (bounds g) (edges g ++ reverseE g) \begin{code} scc :: IntGraph -> Forest Vertex scc g = dfs g (reverse (postOrd (transpose g))) + +sccFrom :: IntGraph -> [Vertex] -> Forest Vertex +sccFrom g vs = reverse (dfs (transpose g) (reverse (postOrdFrom g vs))) \end{code} ------------------------------------------------------------ diff --git a/compiler/utils/Encoding.hs b/compiler/utils/Encoding.hs index 6467377a1a..c4a669c134 100644 --- a/compiler/utils/Encoding.hs +++ b/compiler/utils/Encoding.hs @@ -32,8 +32,7 @@ module Encoding ( import Foreign import Data.Char import Numeric -import GHC.Ptr ( Ptr(..) ) -import GHC.Base +import ExtsCompat46 -- ----------------------------------------------------------------------------- -- UTF-8 diff --git a/compiler/utils/ExtsCompat46.hs b/compiler/utils/ExtsCompat46.hs new file mode 100644 index 0000000000..da0e67ab93 --- /dev/null +++ b/compiler/utils/ExtsCompat46.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE BangPatterns, CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : ExtsCompat46 +-- Copyright : (c) Lodz University of Technology 2013 +-- License : see LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC internal) +-- +-- Compatibility module to encapsulate primops API change between GHC 7.6 +-- GHC 7.8. +-- +-- In GHC we use comparison primops in a couple of modules, but that primops +-- have different type signature in GHC 7.6 (where they return Bool) than +-- in GHC 7.8 (where they return Int#). As long as we allow bootstrapping +-- with GHC 7.6 or earlier we need to have this compatibility module, so that +-- we can compile stage1 compiler using the old API and then continue with +-- stage2 using the new API. When we set GHC 7.8 as the minimum version +-- required for bootstrapping, we should remove this module. +-- +----------------------------------------------------------------------------- + +module ExtsCompat46 ( + module GHC.Exts, + + gtChar#, geChar#, eqChar#, + neChar#, ltChar#, leChar#, + + (>#), (>=#), (==#), (/=#), (<#), (<=#), + + gtWord#, geWord#, eqWord#, + neWord#, ltWord#, leWord#, + + (>##), (>=##), (==##), (/=##), (<##), (<=##), + + gtFloat#, geFloat#, eqFloat#, + neFloat#, ltFloat#, leFloat#, + + gtAddr#, geAddr#, eqAddr#, + neAddr#, ltAddr#, leAddr#, + + sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#, + sameMutVar#, sameTVar#, sameMVar# + + ) where + +import GHC.Exts hiding ( + gtChar#, geChar#, eqChar#, + neChar#, ltChar#, leChar#, + + (>#), (>=#), (==#), (/=#), (<#), (<=#), + + gtWord#, geWord#, eqWord#, + neWord#, ltWord#, leWord#, + + (>##), (>=##), (==##), (/=##), (<##), (<=##), + + gtFloat#, geFloat#, eqFloat#, + neFloat#, ltFloat#, leFloat#, + + gtAddr#, geAddr#, eqAddr#, + neAddr#, ltAddr#, leAddr#, + + sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#, + sameMutVar#, sameTVar#, sameMVar# + ) + +import qualified GHC.Exts as E ( + gtChar#, geChar#, eqChar#, + neChar#, ltChar#, leChar#, + + (>#), (>=#), (==#), (/=#), (<#), (<=#), + + gtWord#, geWord#, eqWord#, + neWord#, ltWord#, leWord#, + + (>##), (>=##), (==##), (/=##), (<##), (<=##), + + gtFloat#, geFloat#, eqFloat#, + neFloat#, ltFloat#, leFloat#, + + gtAddr#, geAddr#, eqAddr#, + neAddr#, ltAddr#, leAddr#, + + sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#, + sameMutVar#, sameTVar#, sameMVar# + ) + +-- See #8330 +#if __GLASGOW_HASKELL__ > 710 +#error What is minimal version of GHC required for bootstraping? If it's GHC 7.8 we should remove this module and use GHC.Exts instead. +#endif + +#if __GLASGOW_HASKELL__ > 706 + +gtChar# :: Char# -> Char# -> Bool +gtChar# a b = isTrue# (a `E.gtChar#` b) +geChar# :: Char# -> Char# -> Bool +geChar# a b = isTrue# (a `E.geChar#` b) +eqChar# :: Char# -> Char# -> Bool +eqChar# a b = isTrue# (a `E.eqChar#` b) +neChar# :: Char# -> Char# -> Bool +neChar# a b = isTrue# (a `E.neChar#` b) +ltChar# :: Char# -> Char# -> Bool +ltChar# a b = isTrue# (a `E.ltChar#` b) +leChar# :: Char# -> Char# -> Bool +leChar# a b = isTrue# (a `E.leChar#` b) + +infix 4 >#, >=#, ==#, /=#, <#, <=# + +(>#) :: Int# -> Int# -> Bool +(>#) a b = isTrue# (a E.># b) +(>=#) :: Int# -> Int# -> Bool +(>=#) a b = isTrue# (a E.>=# b) +(==#) :: Int# -> Int# -> Bool +(==#) a b = isTrue# (a E.==# b) +(/=#) :: Int# -> Int# -> Bool +(/=#) a b = isTrue# (a E./=# b) +(<#) :: Int# -> Int# -> Bool +(<#) a b = isTrue# (a E.<# b) +(<=#) :: Int# -> Int# -> Bool +(<=#) a b = isTrue# (a E.<=# b) + +gtWord# :: Word# -> Word# -> Bool +gtWord# a b = isTrue# (a `E.gtWord#` b) +geWord# :: Word# -> Word# -> Bool +geWord# a b = isTrue# (a `E.geWord#` b) +eqWord# :: Word# -> Word# -> Bool +eqWord# a b = isTrue# (a `E.eqWord#` b) +neWord# :: Word# -> Word# -> Bool +neWord# a b = isTrue# (a `E.neWord#` b) +ltWord# :: Word# -> Word# -> Bool +ltWord# a b = isTrue# (a `E.ltWord#` b) +leWord# :: Word# -> Word# -> Bool +leWord# a b = isTrue# (a `E.leWord#` b) + +infix 4 >##, >=##, ==##, /=##, <##, <=## + +(>##) :: Double# -> Double# -> Bool +(>##) a b = isTrue# (a E.>## b) +(>=##) :: Double# -> Double# -> Bool +(>=##) a b = isTrue# (a E.>=## b) +(==##) :: Double# -> Double# -> Bool +(==##) a b = isTrue# (a E.==## b) +(/=##) :: Double# -> Double# -> Bool +(/=##) a b = isTrue# (a E./=## b) +(<##) :: Double# -> Double# -> Bool +(<##) a b = isTrue# (a E.<## b) +(<=##) :: Double# -> Double# -> Bool +(<=##) a b = isTrue# (a E.<=## b) + +gtFloat# :: Float# -> Float# -> Bool +gtFloat# a b = isTrue# (a `E.gtFloat#` b) +geFloat# :: Float# -> Float# -> Bool +geFloat# a b = isTrue# (a `E.geFloat#` b) +eqFloat# :: Float# -> Float# -> Bool +eqFloat# a b = isTrue# (a `E.eqFloat#` b) +neFloat# :: Float# -> Float# -> Bool +neFloat# a b = isTrue# (a `E.neFloat#` b) +ltFloat# :: Float# -> Float# -> Bool +ltFloat# a b = isTrue# (a `E.ltFloat#` b) +leFloat# :: Float# -> Float# -> Bool +leFloat# a b = isTrue# (a `E.leFloat#` b) + +gtAddr# :: Addr# -> Addr# -> Bool +gtAddr# a b = isTrue# (a `E.gtAddr#` b) +geAddr# :: Addr# -> Addr# -> Bool +geAddr# a b = isTrue# (a `E.geAddr#` b) +eqAddr# :: Addr# -> Addr# -> Bool +eqAddr# a b = isTrue# (a `E.eqAddr#` b) +neAddr# :: Addr# -> Addr# -> Bool +neAddr# a b = isTrue# (a `E.neAddr#` b) +ltAddr# :: Addr# -> Addr# -> Bool +ltAddr# a b = isTrue# (a `E.ltAddr#` b) +leAddr# :: Addr# -> Addr# -> Bool +leAddr# a b = isTrue# (a `E.leAddr#` b) + +sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool +sameMutableArray# a b = isTrue# (E.sameMutableArray# a b) +sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool +sameMutableByteArray# a b = isTrue# (E.sameMutableByteArray# a b) +sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Bool +sameMutableArrayArray# a b = isTrue# (E.sameMutableArrayArray# a b) + +sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool +sameMutVar# a b = isTrue# (E.sameMutVar# a b) +sameTVar# :: TVar# s a -> TVar# s a -> Bool +sameTVar# a b = isTrue# (E.sameTVar# a b) +sameMVar# :: MVar# s a -> MVar# s a -> Bool +sameMVar# a b = isTrue# (E.sameMVar# a b) + +#else + +gtChar# :: Char# -> Char# -> Bool +gtChar# a b = a `E.gtChar#` b +geChar# :: Char# -> Char# -> Bool +geChar# a b = a `E.geChar#` b +eqChar# :: Char# -> Char# -> Bool +eqChar# a b = a `E.eqChar#` b +neChar# :: Char# -> Char# -> Bool +neChar# a b = a `E.neChar#` b +ltChar# :: Char# -> Char# -> Bool +ltChar# a b = a `E.ltChar#` b +leChar# :: Char# -> Char# -> Bool +leChar# a b = a `E.leChar#` b + +infix 4 >#, >=#, ==#, /=#, <#, <=# + +(>#) :: Int# -> Int# -> Bool +(>#) a b = a E.># b +(>=#) :: Int# -> Int# -> Bool +(>=#) a b = a E.>=# b +(==#) :: Int# -> Int# -> Bool +(==#) a b = a E.==# b +(/=#) :: Int# -> Int# -> Bool +(/=#) a b = a E./=# b +(<#) :: Int# -> Int# -> Bool +(<#) a b = a E.<# b +(<=#) :: Int# -> Int# -> Bool +(<=#) a b = a E.<=# b + +gtWord# :: Word# -> Word# -> Bool +gtWord# a b = a `E.gtWord#` b +geWord# :: Word# -> Word# -> Bool +geWord# a b = a `E.geWord#` b +eqWord# :: Word# -> Word# -> Bool +eqWord# a b = a `E.eqWord#` b +neWord# :: Word# -> Word# -> Bool +neWord# a b = a `E.neWord#` b +ltWord# :: Word# -> Word# -> Bool +ltWord# a b = a `E.ltWord#` b +leWord# :: Word# -> Word# -> Bool +leWord# a b = a `E.leWord#` b + +infix 4 >##, >=##, ==##, /=##, <##, <=## + +(>##) :: Double# -> Double# -> Bool +(>##) a b = a E.>## b +(>=##) :: Double# -> Double# -> Bool +(>=##) a b = a E.>=## b +(==##) :: Double# -> Double# -> Bool +(==##) a b = a E.==## b +(/=##) :: Double# -> Double# -> Bool +(/=##) a b = a E./=## b +(<##) :: Double# -> Double# -> Bool +(<##) a b = a E.<## b +(<=##) :: Double# -> Double# -> Bool +(<=##) a b = a E.<=## b + +gtFloat# :: Float# -> Float# -> Bool +gtFloat# a b = a `E.gtFloat#` b +geFloat# :: Float# -> Float# -> Bool +geFloat# a b = a `E.geFloat#` b +eqFloat# :: Float# -> Float# -> Bool +eqFloat# a b = a `E.eqFloat#` b +neFloat# :: Float# -> Float# -> Bool +neFloat# a b = a `E.neFloat#` b +ltFloat# :: Float# -> Float# -> Bool +ltFloat# a b = a `E.ltFloat#` b +leFloat# :: Float# -> Float# -> Bool +leFloat# a b = a `E.leFloat#` b + +gtAddr# :: Addr# -> Addr# -> Bool +gtAddr# a b = a `E.gtAddr#` b +geAddr# :: Addr# -> Addr# -> Bool +geAddr# a b = a `E.geAddr#` b +eqAddr# :: Addr# -> Addr# -> Bool +eqAddr# a b = a `E.eqAddr#` b +neAddr# :: Addr# -> Addr# -> Bool +neAddr# a b = a `E.neAddr#` b +ltAddr# :: Addr# -> Addr# -> Bool +ltAddr# a b = a `E.ltAddr#` b +leAddr# :: Addr# -> Addr# -> Bool +leAddr# a b = a `E.leAddr#` b + +sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool +sameMutableArray# a b = E.sameMutableArray# a b +sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool +sameMutableByteArray# a b = E.sameMutableByteArray# a b +sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Bool +sameMutableArrayArray# a b = E.sameMutableArrayArray# a b + +sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool +sameMutVar# a b = E.sameMutVar# a b +sameTVar# :: TVar# s a -> TVar# s a -> Bool +sameTVar# a b = E.sameTVar# a b +sameMVar# :: MVar# s a -> MVar# s a -> Bool +sameMVar# a b = E.sameMVar# a b + +#endif
\ No newline at end of file diff --git a/compiler/utils/FastMutInt.lhs b/compiler/utils/FastMutInt.lhs index d29bb9136c..7156cdc9fb 100644 --- a/compiler/utils/FastMutInt.lhs +++ b/compiler/utils/FastMutInt.lhs @@ -1,28 +1,20 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# LANGUAGE BangPatterns #-} {-# OPTIONS -cpp #-} {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected - -- -- (c) The University of Glasgow 2002-2006 -- -- Unboxed mutable Ints module FastMutInt( - FastMutInt, newFastMutInt, - readFastMutInt, writeFastMutInt, + FastMutInt, newFastMutInt, + readFastMutInt, writeFastMutInt, - FastMutPtr, newFastMutPtr, - readFastMutPtr, writeFastMutPtr + FastMutPtr, newFastMutPtr, + readFastMutPtr, writeFastMutPtr ) where #ifdef __GLASGOW_HASKELL__ diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 1eeab0f561..5a78c0b59b 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -10,18 +10,20 @@ -- | -- There are two principal string types used internally by GHC: -- --- 'FastString': --- * A compact, hash-consed, representation of character strings. --- * Comparison is O(1), and you can get a 'Unique.Unique' from them. --- * Generated by 'fsLit'. --- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. +-- ['FastString'] -- --- 'LitString': --- * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@). --- * Practically no operations. --- * Outputing them is fast. --- * Generated by 'sLit'. --- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' +-- * A compact, hash-consed, representation of character strings. +-- * Comparison is O(1), and you can get a 'Unique.Unique' from them. +-- * Generated by 'fsLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. +-- +-- ['LitString'] +-- +-- * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@). +-- * Practically no operations. +-- * Outputing them is fast. +-- * Generated by 'sLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' -- -- Use 'LitString' unless you want the facilities of 'FastString'. module FastString @@ -79,17 +81,17 @@ module FastString -- * LitStrings LitString, - + -- ** Construction sLit, #if defined(__GLASGOW_HASKELL__) mkLitString#, #endif mkLitString, - + -- ** Deconstruction unpackLitString, - + -- ** Operations lengthLS ) where @@ -102,24 +104,30 @@ import FastFunctions import Panic import Util +import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import Foreign.C -import GHC.Exts +import ExtsCompat46 import System.IO import System.IO.Unsafe ( unsafePerformIO ) import Data.Data -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Data.IORef ( IORef, newIORef, readIORef, atomicModifyIORef ) import Data.Maybe ( isJust ) import Data.Char +import Data.List ( elemIndex ) -import GHC.IO ( IO(..) ) +import GHC.IO ( IO(..), unsafeDupablePerformIO ) import Foreign.Safe +#if STAGE >= 2 +import GHC.Conc.Sync (sharedCAF) +#endif + #if defined(__GLASGOW_HASKELL__) import GHC.Base ( unpackCString# ) #endif @@ -207,116 +215,175 @@ cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) = if u1 == u2 then EQ else compare (fastStringToByteString f1) (fastStringToByteString f2) -#ifndef __HADDOCK__ foreign import ccall unsafe "ghc_memcmp" memcmp :: Ptr a -> Ptr b -> Int -> IO Int -#endif -- ----------------------------------------------------------------------------- -- Construction {- -Internally, the compiler will maintain a fast string symbol -table, providing sharing and fast comparison. Creation of -new @FastString@s then covertly does a lookup, re-using the -@FastString@ if there was a hit. --} +Internally, the compiler will maintain a fast string symbol table, providing +sharing and fast comparison. Creation of new @FastString@s then covertly does a +lookup, re-using the @FastString@ if there was a hit. + +The design of the FastString hash table allows for lockless concurrent reads +and updates to multiple buckets with low synchronization overhead. +See Note [Updating the FastString table] on how it's updated. +-} data FastStringTable = FastStringTable - {-# UNPACK #-} !Int - (MutableArray# RealWorld [FastString]) + {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets + (MutableArray# RealWorld (IORef [FastString])) -- the array of mutable buckets +string_table :: FastStringTable {-# NOINLINE string_table #-} -string_table :: IORef FastStringTable -string_table = - unsafePerformIO $ do - tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of - (# s2#, arr# #) -> - (# s2#, FastStringTable 0 arr# #) - newIORef tab - -lookupTbl :: FastStringTable -> Int -> IO [FastString] +string_table = unsafePerformIO $ do + uid <- newIORef 0 + tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED (panic "string_table") s1# of + (# s2#, arr# #) -> + (# s2#, FastStringTable uid arr# #) + forM_ [0.. hASH_TBL_SIZE-1] $ \i -> do + bucket <- newIORef [] + updTbl tab i bucket + + -- use the support wired into the RTS to share this CAF among all images of + -- libHSghc +#if STAGE < 2 + return tab +#else + sharedCAF tab getOrSetLibHSghcFastStringTable + +-- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous +-- RTS might not have this symbol +foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" + getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) +#endif + +{- + +We include the FastString table in the `sharedCAF` mechanism because we'd like +FastStrings created by a Core plugin to have the same uniques as corresponding +strings created by the host compiler itself. For example, this allows plugins +to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or +even re-invoke the parser. + +In particular, the following little sanity test was failing in a plugin +prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not +be looked up /by the plugin/. + + let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" + putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts + +`mkTcOcc` involves the lookup (or creation) of a FastString. Since the +plugin's FastString.string_table is empty, constructing the RdrName also +allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These +uniques are almost certainly unequal to the ones that the host compiler +originally assigned to those FastStrings. Thus the lookup fails since the +domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's +unique. + +The old `reinitializeGlobals` mechanism is enough to provide the plugin with +read-access to the table, but it insufficient in the general case where the +plugin may allocate FastStrings. This mutates the supply for the FastStrings' +unique, and that needs to be propagated back to the compiler's instance of the +global variable. Such propagation is beyond the `reinitializeGlobals` +mechanism. + +Maintaining synchronization of the two instances of this global is rather +difficult because of the uses of `unsafePerformIO` in this module. Not +synchronizing them risks breaking the rather major invariant that two +FastStrings with the same unique have the same string. Thus we use the +lower-level `sharedCAF` mechanism that relies on Globals.c. + +-} + +lookupTbl :: FastStringTable -> Int -> IO (IORef [FastString]) lookupTbl (FastStringTable _ arr#) (I# i#) = IO $ \ s# -> readArray# arr# i# s# -updTbl :: IORef FastStringTable -> FastStringTable -> Int -> [FastString] -> IO () -updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do +updTbl :: FastStringTable -> Int -> IORef [FastString] -> IO () +updTbl (FastStringTable _uid arr#) (I# i#) ls = do (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) }) - writeIORef fs_table_var (FastStringTable (uid+1) arr#) mkFastString# :: Addr# -> FastString mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) where ptr = Ptr a# +{- Note [Updating the FastString table] + +The procedure goes like this: + +1. Read the relevant bucket and perform a look up of the string. +2. If it exists, return it. +3. Otherwise grab a unique ID, create a new FastString and atomically attempt + to update the relevant bucket with this FastString: + + * Double check that the string is not in the bucket. Another thread may have + inserted it while we were creating our string. + * Return the existing FastString if it exists. The one we preemptively + created will get GCed. + * Otherwise, insert and return the string we created. +-} + +{- Note [Double-checking the bucket] + +It is not necessary to check the entire bucket the second time. We only have to +check the strings that are new to the bucket since the last time we read it. +-} + +mkFastStringWith :: (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString +mkFastStringWith mk_fs !ptr !len = do + let hash = hashStr ptr len + bucket <- lookupTbl string_table hash + ls1 <- readIORef bucket + res <- bucket_match ls1 len ptr + case res of + Just v -> return v + Nothing -> do + n <- get_uid + new_fs <- mk_fs n + + atomicModifyIORef bucket $ \ls2 -> + -- Note [Double-checking the bucket] + let delta_ls = case ls1 of + [] -> ls2 + l:_ -> case l `elemIndex` ls2 of + Nothing -> panic "mkFastStringWith" + Just idx -> take idx ls2 + + -- NB: Might as well use inlinePerformIO, since the call to + -- bucket_match doesn't perform any IO that could be floated + -- out of this closure or erroneously duplicated. + in case inlinePerformIO (bucket_match delta_ls len ptr) of + Nothing -> (new_fs:ls2, new_fs) + Just fs -> (ls2,fs) + where + !(FastStringTable uid _arr) = string_table + + get_uid = atomicModifyIORef uid $ \n -> (n+1,n) + mkFastStringBytes :: Ptr Word8 -> Int -> FastString -mkFastStringBytes ptr len = unsafePerformIO $ do - ft@(FastStringTable uid _) <- readIORef string_table - let - h = hashStr ptr len - add_it ls = do - fs <- copyNewFastString uid ptr len - updTbl string_table ft h (fs:ls) - {- _trace ("new: " ++ show f_str) $ -} - return fs - -- - lookup_result <- lookupTbl ft h - case lookup_result of - [] -> add_it [] - ls -> do - b <- bucket_match ls len ptr - case b of - Nothing -> add_it ls - Just v -> {- _trace ("re-use: "++show v) $ -} return v +mkFastStringBytes !ptr !len = + -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- idempotent. + unsafeDupablePerformIO $ + mkFastStringWith (copyNewFastString ptr len) ptr len -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference -- between this and 'mkFastStringBytes' is that we don't have to copy -- the bytes if the string is new to the table. mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString -mkFastStringForeignPtr ptr fp len = do - ft@(FastStringTable uid _) <- readIORef string_table --- _trace ("hashed: "++show (I# h)) $ - let - h = hashStr ptr len - add_it ls = do - fs <- mkNewFastString uid ptr fp len - updTbl string_table ft h (fs:ls) - {- _trace ("new: " ++ show f_str) $ -} - return fs - -- - lookup_result <- lookupTbl ft h - case lookup_result of - [] -> add_it [] - ls -> do - b <- bucket_match ls len ptr - case b of - Nothing -> add_it ls - Just v -> {- _trace ("re-use: "++show v) $ -} return v +mkFastStringForeignPtr ptr !fp len + = mkFastStringWith (mkNewFastString fp ptr len) ptr len -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference -- between this and 'mkFastStringBytes' is that we don't have to copy -- the bytes if the string is new to the table. mkFastStringByteString :: ByteString -> IO FastString mkFastStringByteString bs = BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do - ft@(FastStringTable uid _) <- readIORef string_table --- _trace ("hashed: "++show (I# h)) $ - let - ptr' = castPtr ptr - h = hashStr ptr' len - add_it ls = do - fs <- mkNewFastStringByteString uid ptr' len bs - updTbl string_table ft h (fs:ls) - {- _trace ("new: " ++ show f_str) $ -} - return fs - -- - lookup_result <- lookupTbl ft h - case lookup_result of - [] -> add_it [] - ls -> do - b <- bucket_match ls len ptr' - case b of - Nothing -> add_it ls - Just v -> {- _trace ("re-use: "++show v) $ -} return v + let ptr' = castPtr ptr + mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len -- | Creates a UTF-8 encoded 'FastString' from a 'String' mkFastString :: String -> FastString @@ -353,22 +420,22 @@ bucket_match (v@(FastString _ _ bs _):ls) len ptr | otherwise = bucket_match ls len ptr -mkNewFastString :: Int -> Ptr Word8 -> ForeignPtr Word8 -> Int +mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int -> IO FastString -mkNewFastString uid ptr fp len = do +mkNewFastString fp ptr len uid = do ref <- newIORef Nothing n_chars <- countUTF8Chars ptr len return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref) -mkNewFastStringByteString :: Int -> Ptr Word8 -> Int -> ByteString +mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int -> IO FastString -mkNewFastStringByteString uid ptr len bs = do +mkNewFastStringByteString bs ptr len uid = do ref <- newIORef Nothing n_chars <- countUTF8Chars ptr len return (FastString uid n_chars bs ref) -copyNewFastString :: Int -> Ptr Word8 -> Int -> IO FastString -copyNewFastString uid ptr len = do +copyNewFastString :: Ptr Word8 -> Int -> Int -> IO FastString +copyNewFastString ptr len uid = do fp <- copyBytesToForeignPtr ptr len ref <- newIORef Nothing n_chars <- countUTF8Chars ptr len @@ -390,10 +457,10 @@ hashStr :: Ptr Word8 -> Int -> Int -- use the Addr to produce a hash value between 0 & m (inclusive) hashStr (Ptr a#) (I# len#) = loop 0# 0# where - loop h n | n GHC.Exts.==# len# = I# h - | otherwise = loop h2 (n GHC.Exts.+# 1#) + loop h n | n ExtsCompat46.==# len# = I# h + | otherwise = loop h2 (n ExtsCompat46.+# 1#) where !c = ord# (indexCharOffAddr# a# n) - !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` + !h2 = (c ExtsCompat46.+# (h ExtsCompat46.*# 128#)) `remInt#` hASH_TBL_SIZE# -- ----------------------------------------------------------------------------- @@ -437,9 +504,10 @@ zEncodeFS fs@(FastString _ _ _ ref) = case m of Just zfs -> return zfs Nothing -> do - let zfs = mkZFastString (zEncodeString (unpackFS fs)) - writeIORef ref (Just zfs) - return zfs + atomicModifyIORef ref $ \m' -> case m' of + Nothing -> let zfs = mkZFastString (zEncodeString (unpackFS fs)) + in (Just zfs, zfs) + Just zfs -> (m', zfs) appendFS :: FastString -> FastString -> FastString appendFS fs1 fs2 = inlinePerformIO @@ -478,8 +546,9 @@ nilFS = mkFastString "" getFastStringTable :: IO [[FastString]] getFastStringTable = do - tbl <- readIORef string_table - buckets <- mapM (lookupTbl tbl) [0 .. hASH_TBL_SIZE] + buckets <- forM [0.. hASH_TBL_SIZE-1] $ \idx -> do + bucket <- lookupTbl string_table idx + readIORef bucket return buckets -- ----------------------------------------------------------------------------- diff --git a/compiler/utils/FastTypes.lhs b/compiler/utils/FastTypes.lhs index ace46e6e1b..0ef10ade56 100644 --- a/compiler/utils/FastTypes.lhs +++ b/compiler/utils/FastTypes.lhs @@ -14,10 +14,10 @@ module FastTypes ( -- * FastInt FastInt, - + -- ** Getting in and out of FastInt _ILIT, iBox, iUnbox, - + -- ** Arithmetic on FastInt (+#), (-#), (*#), quotFastInt, negateFastInt, --quotRemFastInt is difficult because unboxed values can't @@ -51,11 +51,11 @@ module FastTypes ( --character values above the range of Unicode -- * FastPtr - FastPtr, - + FastPtr, + -- ** Getting in and out of FastPtr pBox, pUnbox, - + -- ** Casting FastPtrs castFastPtr ) where @@ -65,7 +65,7 @@ module FastTypes ( #if defined(__GLASGOW_HASKELL__) -- Import the beggars -import GHC.Exts +import ExtsCompat46 type FastInt = Int# diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc index 95f31c08bb..9a55e385b3 100644 --- a/compiler/utils/Fingerprint.hsc +++ b/compiler/utils/Fingerprint.hsc @@ -1,25 +1,33 @@ -- ---------------------------------------------------------------------------- --- +-- -- (c) The University of Glasgow 2006 -- -- Fingerprints for recompilation checking and ABI versioning. -- --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance -- -- ---------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-} module Fingerprint ( Fingerprint(..), fingerprint0, readHexFingerprint, fingerprintData, - fingerprintString + fingerprintString, + -- Re-exported from GHC.Fingerprint for GHC >= 7.7, local otherwise + getFileHash ) where #include "md5.h" ##include "HsVersions.h" import Numeric ( readHex ) +#if __GLASGOW_HASKELL__ < 707 +-- Only needed for getFileHash below. +import Foreign +import Panic +import System.IO +import Control.Monad ( when ) +#endif import GHC.Fingerprint @@ -30,3 +38,32 @@ readHexFingerprint s = Fingerprint w1 w2 [(w1,"")] = readHex s1 [(w2,"")] = readHex (take 16 s2) + +#if __GLASGOW_HASKELL__ < 707 +-- Only use this if we're smaller than GHC 7.7, otherwise +-- GHC.Fingerprint exports a better version of this function. + +-- | Computes the hash of a given file. +-- It loads the full file into memory an does not work with files bigger than +-- MAXINT. +getFileHash :: FilePath -> IO Fingerprint +getFileHash path = withBinaryFile path ReadMode $ \h -> do + + fileSize <- toIntFileSize `fmap` hFileSize h + + allocaBytes fileSize $ \bufPtr -> do + n <- hGetBuf h bufPtr fileSize + when (n /= fileSize) readFailedError + fingerprintData bufPtr fileSize + + where + toIntFileSize :: Integer -> Int + toIntFileSize size + | size > fromIntegral (maxBound :: Int) = throwGhcException $ + Sorry $ "Fingerprint.getFileHash: Tried to calculate hash of file " + ++ path ++ " with size > maxBound :: Int. This is not supported." + | otherwise = fromIntegral size + + readFailedError = throwGhcException $ + Panic $ "Fingerprint.getFileHash: hGetBuf failed on interface file" +#endif diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs index 94d1eef94e..b52f28c324 100644 --- a/compiler/utils/FiniteMap.lhs +++ b/compiler/utils/FiniteMap.lhs @@ -27,10 +27,6 @@ deleteList ks m = foldl (flip Map.delete) m ks foldRight :: (elt -> a -> a) -> a -> Map key elt -> a foldRight = Map.fold foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a -#if (MIN_VERSION_containers(0,4,0)) foldRightWithKey = Map.foldrWithKey -#else -foldRightWithKey = Map.foldWithKey -#endif \end{code} diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs index c070df4762..8cb3acee71 100644 --- a/compiler/utils/GraphBase.hs +++ b/compiler/utils/GraphBase.hs @@ -5,7 +5,7 @@ -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details module GraphBase ( diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs index 5ea5fdfb75..a896bbbf63 100644 --- a/compiler/utils/GraphPpr.hs +++ b/compiler/utils/GraphPpr.hs @@ -5,7 +5,7 @@ -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details module GraphPpr ( diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 583e875903..6885bbd127 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -22,7 +22,7 @@ module IOEnv ( -- Getting at the environment getEnv, setEnv, updEnv, - runIOEnv, unsafeInterleaveM, + runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, tryM, tryAllM, tryMostM, fixM, -- I/O operations @@ -42,6 +42,7 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO ( fixIO ) import Control.Monad import MonadUtils +import Control.Applicative (Alternative(..)) ---------------------------------------------------------------------- -- Defining the monad type @@ -148,11 +149,17 @@ tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) unsafeInterleaveM :: IOEnv env a -> IOEnv env a unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) +uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a +uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) ---------------------------------------------------------------------- --- MonadPlus +-- Alternative/MonadPlus ---------------------------------------------------------------------- +instance MonadPlus IO => Alternative (IOEnv env) where + empty = mzero + (<|>) = mplus + -- For use if the user has imported Control.Monad.Error from MTL -- Requires UndecidableInstances instance MonadPlus IO => MonadPlus (IOEnv env) where diff --git a/compiler/utils/Maybes.lhs b/compiler/utils/Maybes.lhs index 210a7b9f02..d9e1762a2f 100644 --- a/compiler/utils/Maybes.lhs +++ b/compiler/utils/Maybes.lhs @@ -4,13 +4,6 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Maybes ( module Data.Maybe, @@ -18,15 +11,14 @@ module Maybes ( failME, isSuccess, orElse, - mapCatMaybes, - allMaybes, firstJust, firstJusts, + whenIsJust, expectJust, - maybeToBool, MaybeT(..) ) where - +import Control.Applicative +import Control.Monad import Data.Maybe infixr 4 `orElse` @@ -39,55 +31,32 @@ infixr 4 `orElse` %************************************************************************ \begin{code} -maybeToBool :: Maybe a -> Bool -maybeToBool Nothing = False -maybeToBool (Just _) = True - --- | Collects a list of @Justs@ into a single @Just@, returning @Nothing@ if --- there are any @Nothings@. -allMaybes :: [Maybe a] -> Maybe [a] -allMaybes [] = Just [] -allMaybes (Nothing : _) = Nothing -allMaybes (Just x : ms) = case allMaybes ms of - Nothing -> Nothing - Just xs -> Just (x:xs) - firstJust :: Maybe a -> Maybe a -> Maybe a -firstJust (Just a) _ = Just a -firstJust Nothing b = b +firstJust a b = firstJusts [a, b] -- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or -- @Nothing@ otherwise. firstJusts :: [Maybe a] -> Maybe a -firstJusts = foldr firstJust Nothing -\end{code} +firstJusts = msum -\begin{code} expectJust :: String -> Maybe a -> a {-# INLINE expectJust #-} expectJust _ (Just x) = x expectJust err Nothing = error ("expectJust " ++ err) -\end{code} -\begin{code} -mapCatMaybes :: (a -> Maybe b) -> [a] -> [b] -mapCatMaybes _ [] = [] -mapCatMaybes f (x:xs) = case f x of - Just y -> y : mapCatMaybes f xs - Nothing -> mapCatMaybes f xs -\end{code} +whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenIsJust (Just x) f = f x +whenIsJust Nothing _ = return () -\begin{code} --- | flipped version of @fromMaybe@. +-- | Flipped version of @fromMaybe@, useful for chaining. orElse :: Maybe a -> a -> a -(Just x) `orElse` _ = x -Nothing `orElse` y = y +orElse = flip fromMaybe \end{code} %************************************************************************ -%* * +%* * \subsection[MaybeT type]{The @MaybeT@ monad transformer} -%* * +%* * %************************************************************************ \begin{code} @@ -97,6 +66,10 @@ newtype MaybeT m a = MaybeT {runMaybeT :: m (Maybe a)} instance Functor m => Functor (MaybeT m) where fmap f x = MaybeT $ fmap (fmap f) $ runMaybeT x +instance (Monad m, Functor m) => Applicative (MaybeT m) where + pure = return + (<*>) = ap + instance Monad m => Monad (MaybeT m) where return = MaybeT . return . Just x >>= f = MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f) @@ -114,6 +87,13 @@ instance Monad m => Monad (MaybeT m) where \begin{code} data MaybeErr err val = Succeeded val | Failed err +instance Functor (MaybeErr err) where + fmap = liftM + +instance Applicative (MaybeErr err) where + pure = return + (<*>) = ap + instance Monad (MaybeErr err) where return v = Succeeded v Succeeded v >>= k = k v diff --git a/compiler/utils/OrdList.lhs b/compiler/utils/OrdList.lhs index 7e3b24a5da..d1d8708dd3 100644 --- a/compiler/utils/OrdList.lhs +++ b/compiler/utils/OrdList.lhs @@ -9,15 +9,8 @@ Provide trees (of instructions), so that lists of instructions can be appended in linear time. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module OrdList ( - OrdList, + OrdList, nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, mapOL, fromOL, toOL, foldrOL, foldlOL ) where diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index bd2a955469..e8d9347767 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -32,7 +32,7 @@ module Outputable ( sep, cat, fsep, fcat, hang, punctuate, ppWhen, ppUnless, - speakNth, speakNTimes, speakN, speakNOf, plural, + speakNth, speakNTimes, speakN, speakNOf, plural, isOrAre, coloured, PprColour, colType, colCoerc, colDataCon, colBinder, bold, keyword, @@ -42,8 +42,7 @@ module Outputable ( pprCode, mkCodeStyle, showSDoc, showSDocOneLine, showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, - showPpr, - showSDocUnqual, + showSDocUnqual, showPpr, renderWithStyle, pprInfixVar, pprPrefixVar, @@ -53,7 +52,9 @@ module Outputable ( -- * Controlling the style in which output is printed BindingSite(..), - PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify, + PprStyle, CodeStyle(..), PrintUnqualified, + alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, + neverQualify, neverQualifyNames, neverQualifyModules, QualifyName(..), sdocWithDynFlags, sdocWithPlatform, getPprStyle, withPprStyle, withPprStyleDoc, @@ -75,7 +76,7 @@ import {-# SOURCE #-} DynFlags( DynFlags, useUnicodeQuotes, unsafeGlobalDynFlags ) import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) -import {-# SOURCE #-} Name( Name, nameModule ) +import {-# SOURCE #-} OccName( OccName ) import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput ) import FastString @@ -90,6 +91,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Char import qualified Data.Map as M +import Data.Int import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set @@ -144,13 +146,20 @@ data Depth = AllTheWay -- purpose of the pair of functions that gets passed around -- when rendering 'SDoc'. +type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) + -- | given an /original/ name, this function tells you which module -- name it should be qualified with when printing for the user, if -- any. For example, given @Control.Exception.catch@, which is in scope -- as @Exception.catch@, this fuction will return @Just "Exception"@. -- Note that the return value is a ModuleName, not a Module, because -- in source code, names are qualified by ModuleNames. -type QueryQualifyName = Name -> QualifyName +type QueryQualifyName = Module -> OccName -> QualifyName + +-- | For a given module, we need to know whether to print it with +-- a package name to disambiguate it. +type QueryQualifyModule = Module -> Bool + -- See Note [Printing original names] in HscTypes data QualifyName -- given P:M.T @@ -163,18 +172,11 @@ data QualifyName -- given P:M.T -- it is not in scope at all, and M.T is already bound in the -- current scope, so we must refer to it as "P:M.T" - --- | For a given module, we need to know whether to print it with --- a package name to disambiguate it. -type QueryQualifyModule = Module -> Bool - -type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) - alwaysQualifyNames :: QueryQualifyName -alwaysQualifyNames n = NameQual (moduleName (nameModule n)) +alwaysQualifyNames m _ = NameQual (moduleName m) neverQualifyNames :: QueryQualifyName -neverQualifyNames _ = NameUnqual +neverQualifyNames _ _ = NameUnqual alwaysQualifyModules :: QueryQualifyModule alwaysQualifyModules _ = True @@ -295,8 +297,8 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) \begin{code} qualName :: PprStyle -> QueryQualifyName -qualName (PprUser (qual_name,_) _) n = qual_name n -qualName _other n = NameQual (moduleName (nameModule n)) +qualName (PprUser (qual_name,_) _) mod occ = qual_name mod occ +qualName _other mod _ = NameQual (moduleName mod) qualModule :: PprStyle -> QueryQualifyModule qualModule (PprUser (_,qual_mod) _) m = qual_mod m @@ -363,44 +365,47 @@ mkCodeStyle = PprCode -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: DynFlags -> SDoc -> String -showSDoc dflags d = - Pretty.showDocWith PageMode - (runSDoc d (initSDocContext dflags defaultUserStyle)) +showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String -renderWithStyle dflags sdoc sty = - Pretty.render (runSDoc sdoc (initSDocContext dflags sty)) +renderWithStyle dflags sdoc sty + = Pretty.showDoc PageMode (pprCols dflags) $ + runSDoc sdoc (initSDocContext dflags sty) -- This shows an SDoc, but on one line only. It's cheaper than a full -- showSDoc, designed for when we're getting results like "Foo.bar" -- and "foo{uniq strictness}" so we don't want fancy layout anyway. showSDocOneLine :: DynFlags -> SDoc -> String showSDocOneLine dflags d - = Pretty.showDocWith PageMode - (runSDoc d (initSDocContext dflags defaultUserStyle)) + = Pretty.showDoc OneLineMode (pprCols dflags) $ + runSDoc d (initSDocContext dflags defaultUserStyle) showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String showSDocForUser dflags unqual doc - = show (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay))) + = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay) showSDocUnqual :: DynFlags -> SDoc -> String --- Only used in the gruesome isOperator -showSDocUnqual dflags d - = show (runSDoc d (initSDocContext dflags (mkUserStyle neverQualify AllTheWay))) +-- Only used by Haddock +showSDocUnqual dflags doc + = renderWithStyle dflags doc (mkUserStyle neverQualify AllTheWay) showSDocDump :: DynFlags -> SDoc -> String -showSDocDump dflags d - = Pretty.showDocWith PageMode (runSDoc d (initSDocContext dflags defaultDumpStyle)) +showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle + +showSDocDebug :: DynFlags -> SDoc -> String +showSDocDebug dflags d = renderWithStyle dflags d PprDebug showSDocDumpOneLine :: DynFlags -> SDoc -> String showSDocDumpOneLine dflags d - = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext dflags PprDump)) - -showSDocDebug :: DynFlags -> SDoc -> String -showSDocDebug dflags d = show (runSDoc d (initSDocContext dflags PprDebug)) + = Pretty.showDoc OneLineMode irrelevantNCols $ + runSDoc d (initSDocContext dflags PprDump) showPpr :: Outputable a => DynFlags -> a -> String -showPpr dflags = showSDoc dflags . ppr +showPpr dflags thing = showSDoc dflags (ppr thing) + +irrelevantNCols :: Int +-- Used for OneLineMode and LeftMode when number of cols isn't used +irrelevantNCols = 1 \end{code} \begin{code} @@ -421,7 +426,10 @@ rational :: Rational -> SDoc empty = docToSDoc $ Pretty.empty char c = docToSDoc $ Pretty.char c + text s = docToSDoc $ Pretty.text s +{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire + ftext s = docToSDoc $ Pretty.ftext s ptext s = docToSDoc $ Pretty.ptext s ztext s = docToSDoc $ Pretty.ztext s @@ -452,7 +460,7 @@ cparen b d = SDoc $ Pretty.cparen b . runSDoc d quotes d = sdocWithDynFlags $ \dflags -> if useUnicodeQuotes dflags - then char '‛' <> d <> char '’' + then char '‘' <> d <> char '’' else SDoc $ \sty -> let pp_d = runSDoc d sty str = show pp_d @@ -616,6 +624,12 @@ instance Outputable Bool where ppr True = ptext (sLit "True") ppr False = ptext (sLit "False") +instance Outputable Int32 where + ppr n = integer $ fromIntegral n + +instance Outputable Int64 where + ppr n = integer $ fromIntegral n + instance Outputable Int where ppr n = int n @@ -898,6 +912,15 @@ speakNTimes t | t == 1 = ptext (sLit "once") plural :: [a] -> SDoc plural [_] = empty -- a bit frightening, but there you are plural _ = char 's' + +-- | Determines the form of to be appropriate for the length of a list: +-- +-- > isOrAre [] = ptext (sLit "are") +-- > isOrAre ["Hello"] = ptext (sLit "is") +-- > isOrAre ["Hello", "World"] = ptext (sLit "are") +isOrAre :: [a] -> SDoc +isOrAre [_] = ptext (sLit "is") +isOrAre _ = ptext (sLit "are") \end{code} diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 213a63e0c8..ea1a3e5e93 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -12,7 +12,9 @@ module Platform ( target32Bit, isARM, osElfTarget, + osMachOTarget, platformUsesFrameworks, + platformBinariesAreStaticLibs, ) where @@ -53,6 +55,7 @@ data Arch | ArchAlpha | ArchMipseb | ArchMipsel + | ArchJavaScript deriving (Read, Show, Eq) isARM :: Arch -> Bool @@ -127,6 +130,11 @@ osElfTarget OSUnknown = False -- portability, otherwise we have to answer this question for every -- new platform we compile on (even unreg). +-- | This predicate tells us whether the OS support Mach-O shared libraries. +osMachOTarget :: OS -> Bool +osMachOTarget OSDarwin = True +osMachOTarget _ = False + osUsesFrameworks :: OS -> Bool osUsesFrameworks OSDarwin = True osUsesFrameworks OSiOS = True @@ -135,3 +143,10 @@ osUsesFrameworks _ = False platformUsesFrameworks :: Platform -> Bool platformUsesFrameworks = osUsesFrameworks . platformOS +osBinariesAreStaticLibs :: OS -> Bool +osBinariesAreStaticLibs OSiOS = True +osBinariesAreStaticLibs _ = False + +platformBinariesAreStaticLibs :: Platform -> Bool +platformBinariesAreStaticLibs = osBinariesAreStaticLibs . platformOS + diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index e4f748a05d..fb7fe2b7fb 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -71,7 +71,7 @@ Version 2.0 24 April 1997 nest k empty = empty which wasn't true before. - * Fixed an obscure bug in sep that occassionally gave very wierd behaviour + * Fixed an obscure bug in sep that occasionally gave very weird behaviour * Added $+$ @@ -173,8 +173,7 @@ module Pretty ( hang, punctuate, --- renderStyle, -- Haskell 1.3 only - render, fullRender, printDoc, showDocWith, + fullRender, printDoc, printDoc_, showDoc, bufLeftRender -- performance hack ) where @@ -270,9 +269,8 @@ Displaying @Doc@ values. \begin{code} instance Show Doc where - showsPrec _ doc cont = showDoc doc cont + showsPrec _ doc cont = showDocPlus PageMode 100 doc cont -render :: Doc -> String -- Uses default style fullRender :: Mode -> Int -- Line length -> Float -- Ribbons per line @@ -281,21 +279,10 @@ fullRender :: Mode -> Doc -> a -- Result -{- When we start using 1.3 -renderStyle :: Style -> Doc -> String -data Style = Style { lineLength :: Int, -- In chars - ribbonsPerLine :: Float, -- Ratio of ribbon length to line length - mode :: Mode - } -style :: Style -- The default style -style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode } --} - data Mode = PageMode -- Normal | ZigZagMode -- With zig-zag cuts | LeftMode -- No indentation, infinitely long lines | OneLineMode -- All on one line - \end{code} @@ -557,7 +544,9 @@ isEmpty _ = False char c = textBeside_ (Chr c) (_ILIT(1)) Empty text s = case iUnbox (length s) of {sl -> textBeside_ (Str s) sl Empty} -{-# NOINLINE [1] text #-} -- Give the RULE a chance to fire +{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested ftext :: FastString -> Doc ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty} @@ -888,21 +877,11 @@ oneLiner _ = panic "oneLiner: Unhandled case" \begin{code} -{- -renderStyle Style{mode, lineLength, ribbonsPerLine} doc - = fullRender mode lineLength ribbonsPerLine doc "" --} - -render doc = showDocWith PageMode doc - -showDoc :: Doc -> String -> String -showDoc doc rest = showDocWithAppend PageMode doc rest - -showDocWithAppend :: Mode -> Doc -> String -> String -showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc +showDocPlus :: Mode -> Int -> Doc -> String -> String +showDocPlus mode cols doc rest = fullRender mode cols 1.5 string_txt rest doc -showDocWith :: Mode -> Doc -> String -showDocWith mode doc = showDocWithAppend mode doc "" +showDoc :: Mode -> Int -> Doc -> String +showDoc mode cols doc = showDocPlus mode cols doc "" string_txt :: TextDetails -> String -> String string_txt (Chr c) s = c:s @@ -1006,9 +985,16 @@ spaces n | n <=# _ILIT(0) = "" \begin{code} printDoc :: Mode -> Int -> Handle -> Doc -> IO () -printDoc LeftMode _ hdl doc +-- printDoc adds a newline to the end +printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") + +printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc_ does not add a newline at the end, so that +-- successive calls can output stuff on the same line +-- Rather like putStr vs putStrLn +printDoc_ LeftMode _ hdl doc = do { printLeftRender hdl doc; hFlush hdl } -printDoc mode pprCols hdl doc +printDoc_ mode pprCols hdl doc = do { fullRender mode pprCols 1.5 put done doc ; hFlush hdl } where @@ -1020,7 +1006,7 @@ printDoc mode pprCols hdl doc put (ZStr s) next = hPutFZS hdl s >> next put (LStr s l) next = hPutLitString hdl s l >> next - done = hPutChar hdl '\n' + done = return () -- hPutChar hdl '\n' -- some versions of hPutBuf will barf if the length is zero hPutLitString :: Handle -> Ptr a -> Int# -> IO () diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs index 2fa76d2345..47cdee0789 100644 --- a/compiler/utils/Stream.hs +++ b/compiler/utils/Stream.hs @@ -11,6 +11,8 @@ module Stream ( collect, fromList, Stream.map, Stream.mapM, Stream.mapAccumL ) where +import Control.Monad +import Control.Applicative -- | -- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence @@ -37,6 +39,13 @@ module Stream ( -- newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) } +instance Monad f => Functor (Stream f a) where + fmap = liftM + +instance Monad m => Applicative (Stream m a) where + pure = return + (<*>) = ap + instance Monad m => Monad (Stream m a) where return a = Stream (return (Left a)) @@ -66,7 +75,7 @@ collect str = go str [] fromList :: Monad m => [a] -> Stream m a () fromList = mapM_ yield --- | Apply a function to each element of a 'Stream', lazilly +-- | Apply a function to each element of a 'Stream', lazily map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x map f str = Stream $ do r <- runStream str @@ -74,7 +83,7 @@ map f str = Stream $ do Left x -> return (Left x) Right (a, str') -> return (Right (f a, Stream.map f str')) --- | Apply a monadic operation to each element of a 'Stream', lazilly +-- | Apply a monadic operation to each element of a 'Stream', lazily mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x mapM f str = Stream $ do r <- runStream str diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs new file mode 100644 index 0000000000..228f3b5220 --- /dev/null +++ b/compiler/utils/UnVarGraph.hs @@ -0,0 +1,136 @@ +{- + +Copyright (c) 2014 Joachim Breitner + +A data structure for undirected graphs of variables +(or in plain terms: Sets of unordered pairs of numbers) + + +This is very specifically tailored for the use in CallArity. In particular it +stores the graph as a union of complete and complete bipartite graph, which +would be very expensive to store as sets of edges or as adjanceny lists. + +It does not normalize the graphs. This means that g `unionUnVarGraph` g is +equal to g, but twice as expensive and large. + +-} +module UnVarGraph + ( UnVarSet + , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets + , delUnVarSet + , elemUnVarSet, isEmptyUnVarSet + , UnVarGraph + , emptyUnVarGraph + , unionUnVarGraph, unionUnVarGraphs + , completeGraph, completeBipartiteGraph + , neighbors + , delNode + ) where + +import Id +import VarEnv +import UniqFM +import Outputable +import Data.List +import Bag +import Unique + +import qualified Data.IntSet as S + +-- We need a type for sets of variables (UnVarSet). +-- We do not use VarSet, because for that we need to have the actual variable +-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. +-- Therefore, use a IntSet directly (which is likely also a bit more efficient). + +-- Set of uniques, i.e. for adjancet nodes +newtype UnVarSet = UnVarSet (S.IntSet) + deriving Eq + +k :: Var -> Int +k v = getKey (getUnique v) + +emptyUnVarSet :: UnVarSet +emptyUnVarSet = UnVarSet S.empty + +elemUnVarSet :: Var -> UnVarSet -> Bool +elemUnVarSet v (UnVarSet s) = k v `S.member` s + + +isEmptyUnVarSet :: UnVarSet -> Bool +isEmptyUnVarSet (UnVarSet s) = S.null s + +delUnVarSet :: UnVarSet -> Var -> UnVarSet +delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s + +mkUnVarSet :: [Var] -> UnVarSet +mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs + +varEnvDom :: VarEnv a -> UnVarSet +varEnvDom ae = UnVarSet $ ufmToSet_Directly ae + +unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet +unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) + +unionUnVarSets :: [UnVarSet] -> UnVarSet +unionUnVarSets = foldr unionUnVarSet emptyUnVarSet + +instance Outputable UnVarSet where + ppr (UnVarSet s) = braces $ + hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] + + +-- The graph type. A list of complete bipartite graphs +data Gen = CBPG UnVarSet UnVarSet -- complete bipartite + | CG UnVarSet -- complete +newtype UnVarGraph = UnVarGraph (Bag Gen) + +emptyUnVarGraph :: UnVarGraph +emptyUnVarGraph = UnVarGraph emptyBag + +unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph +{- +Premature optimisation, it seems. +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s1 == s3 && s2 == s4 + = pprTrace "unionUnVarGraph fired" empty $ + completeGraph (s1 `unionUnVarSet` s2) +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s2 == s3 && s1 == s4 + = pprTrace "unionUnVarGraph fired2" empty $ + completeGraph (s1 `unionUnVarSet` s2) +-} +unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) + = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ + UnVarGraph (g1 `unionBags` g2) + +unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph +unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph + +-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } +completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph +completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 + +completeGraph :: UnVarSet -> UnVarGraph +completeGraph s = prune $ UnVarGraph $ unitBag $ CG s + +neighbors :: UnVarGraph -> Var -> UnVarSet +neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g + where go (CG s) = (if v `elemUnVarSet` s then [s] else []) + go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ + (if v `elemUnVarSet` s2 then [s1] else []) + +delNode :: UnVarGraph -> Var -> UnVarGraph +delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g + where go (CG s) = CG (s `delUnVarSet` v) + go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) + +prune :: UnVarGraph -> UnVarGraph +prune (UnVarGraph g) = UnVarGraph $ filterBag go g + where go (CG s) = not (isEmptyUnVarSet s) + go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) + +instance Outputable Gen where + ppr (CG s) = ppr s <> char '²' + ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 +instance Outputable UnVarGraph where + ppr (UnVarGraph g) = ppr g diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index ab39bc87f5..0836e12e28 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -20,7 +20,7 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order of arguments of combining function. \begin{code} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-} {-# OPTIONS -Wall #-} module UniqFM ( @@ -45,6 +45,7 @@ module UniqFM ( delListFromUFM, plusUFM, plusUFM_C, + plusUFM_CD, minusUFM, intersectUFM, intersectUFM_C, @@ -58,6 +59,7 @@ module UniqFM ( lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, eltsUFM, keysUFM, splitUFM, + ufmToSet_Directly, ufmToList, joinUFM ) where @@ -69,10 +71,12 @@ import Compiler.Hoopl hiding (Unique) import Data.Function (on) import qualified Data.IntMap as M +import qualified Data.IntSet as S import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable import Data.Typeable import Data.Data +import Data.Monoid \end{code} %************************************************************************ @@ -135,6 +139,20 @@ plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt +-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the +-- combinding function and `d1` resp. `d2` as the default value if +-- there is no entry in `m1` reps. `m2`. The domain is the union of +-- the domains of `m1` and `m2`. +-- +-- Representative example: +-- +-- @ +-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 +-- == {A: f 1 42, B: f 2 3, C: f 23 4 } +-- @ +plusUFM_CD :: (elt -> elt -> elt) + -> UniqFM elt -> elt -> UniqFM elt -> elt -> UniqFM elt + minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt @@ -166,12 +184,25 @@ lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt keysUFM :: UniqFM elt -> [Unique] -- Get the keys eltsUFM :: UniqFM elt -> [elt] +ufmToSet_Directly :: UniqFM elt -> S.IntSet ufmToList :: UniqFM elt -> [(Unique, elt)] \end{code} %************************************************************************ %* * +\subsection{Monoid interface} +%* * +%************************************************************************ + +\begin{code} +instance Monoid (UniqFM a) where + mempty = emptyUFM + mappend = plusUFM +\end{code} + +%************************************************************************ +%* * \subsection{Implementation using ``Data.IntMap''} %* * %************************************************************************ @@ -224,7 +255,24 @@ delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) -- M.union is left-biased, plusUFM should be right-biased. plusUFM (UFM x) (UFM y) = UFM (M.union y x) + -- Note (M.union y x), with arguments flipped + -- M.union is left-biased, plusUFM should be right-biased. + plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) + +plusUFM_CD f (UFM xm) dx (UFM ym) dy +{- +The following implementation should be used as soon as we can expect +containers-0.5; presumably from GHC 7.9 on: + = UFM $ M.mergeWithKey + (\_ x y -> Just (x `f` y)) + (M.map (\x -> x `f` dy)) + (M.map (\y -> dx `f` y)) + xm ym +-} + = UFM $ M.intersectionWith f xm ym + `M.union` M.map (\x -> x `f` dy) xm + `M.union` M.map (\y -> dx `f` y) ym minusUFM (UFM x) (UFM y) = UFM (M.difference x y) intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) @@ -251,6 +299,7 @@ lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m keysUFM (UFM m) = map getUnique $ M.keys m eltsUFM (UFM m) = M.elems m +ufmToSet_Directly (UFM m) = M.keysSet m ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m -- Hoopl diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.lhs index f8e7d9039f..fae5ddabb6 100644 --- a/compiler/utils/UniqSet.lhs +++ b/compiler/utils/UniqSet.lhs @@ -9,13 +9,6 @@ Based on @UniqFMs@ (as you would expect). Basically, the things need to be in class @Uniquable@. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module UniqSet ( -- * Unique set type UniqSet, -- type synonym for UniqFM a @@ -38,6 +31,7 @@ module UniqSet ( isEmptyUniqSet, lookupUniqSet, uniqSetToList, + partitionUniqSet ) where import UniqFM @@ -46,9 +40,9 @@ import Unique \end{code} %************************************************************************ -%* * +%* * \subsection{The signature of the module} -%* * +%* * %************************************************************************ \begin{code} @@ -74,12 +68,14 @@ mapUniqSet :: (a -> b) -> UniqSet a -> UniqSet b elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool elemUniqSet_Directly :: Unique -> UniqSet a -> Bool filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a +partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) sizeUniqSet :: UniqSet a -> Int isEmptyUniqSet :: UniqSet a -> Bool lookupUniqSet :: Uniquable a => UniqSet a -> a -> Maybe a uniqSetToList :: UniqSet a -> [a] \end{code} + %************************************************************************ %* * \subsection{Implementation using ``UniqFM''} @@ -113,6 +109,7 @@ mapUniqSet = mapUFM elementOfUniqSet = elemUFM elemUniqSet_Directly = elemUFM_Directly filterUniqSet = filterUFM +partitionUniqSet = partitionUFM sizeUniqSet = sizeUFM isEmptyUniqSet = isNullUFM diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 90a2077c71..5c82c757aa 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -14,11 +14,11 @@ module Util ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, - zipLazy, stretchZipWith, + zipLazy, stretchZipWith, zipWithAndUnzip, unzipWith, - mapFst, mapSnd, + mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, mapAccumL2, nOfThem, filterOut, partitionWith, splitEithers, @@ -259,6 +259,13 @@ splitEithers (e : es) = case e of Left x -> (x:xs, ys) Right y -> (xs, y:ys) where (xs,ys) = splitEithers es + +chkAppend :: [a] -> [a] -> [a] +-- Checks for the second arguemnt being empty +-- Used in situations where that situation is common +chkAppend xs ys + | null ys = xs + | otherwise = xs ++ ys \end{code} A paranoid @zip@ (and some @zipWith@ friends) that checks the lists @@ -344,6 +351,14 @@ mapAndUnzip3 f (x:xs) in (r1:rs1, r2:rs2, r3:rs3) +zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) +zipWithAndUnzip f (a:as) (b:bs) + = let (r1, r2) = f a b + (rs1, rs2) = zipWithAndUnzip f as bs + in + (r1:rs1, r2:rs2) +zipWithAndUnzip _ _ _ = ([],[]) + mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) mapAccumL2 f s1 s2 xs = (s1', s2', ys) where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of @@ -559,7 +574,15 @@ splitAtList (_:xs) (y:ys) = (y:ys', ys'') -- drop from the end of a list dropTail :: Int -> [a] -> [a] -dropTail n = reverse . drop n . reverse +-- Specification: dropTail n = reverse . drop n . reverse +-- Better implemention due to Joachim Breitner +-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html +dropTail n xs + = go (drop n xs) xs + where + go (_:ys) (x:xs) = x : go ys xs + go _ _ = [] -- Stop when ys runs out + -- It'll always run out before xs does snocView :: [a] -> Maybe ([a],a) -- Split off the last element @@ -1088,7 +1111,7 @@ charToC w = hashString :: String -> Int32 hashString = foldl' f golden where f m c = fromIntegral (ord c) * magic + hashInt32 m - magic = 0xdeadbeef + magic = fromIntegral (0xdeadbeef :: Word32) golden :: Int32 golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 |