summaryrefslogtreecommitdiff
path: root/compiler/utils
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/utils')
-rw-r--r--compiler/utils/Bag.lhs3
-rw-r--r--compiler/utils/GraphOps.hs15
-rw-r--r--compiler/utils/Outputable.lhs5
-rw-r--r--compiler/utils/UniqFM.lhs23
-rw-r--r--compiler/utils/Util.lhs14
5 files changed, 49 insertions, 11 deletions
diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs
index 097a112359..700878aea6 100644
--- a/compiler/utils/Bag.lhs
+++ b/compiler/utils/Bag.lhs
@@ -41,6 +41,7 @@ data Bag a
| UnitBag a
| TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty
| ListBag [a] -- INVARIANT: the list is non-empty
+ deriving Typeable
emptyBag :: Bag a
emptyBag = EmptyBag
@@ -262,8 +263,6 @@ bagToList b = foldrBag (:) [] b
instance (Outputable a) => Outputable (Bag a) where
ppr bag = braces (pprWithCommas ppr (bagToList bag))
-INSTANCE_TYPEABLE1(Bag,bagTc,"Bag")
-
instance Data a => Data (Bag a) where
gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly
toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")"
diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
index 388b96844c..1fa4199aa2 100644
--- a/compiler/utils/GraphOps.hs
+++ b/compiler/utils/GraphOps.hs
@@ -61,14 +61,14 @@ addNode k node graph
-- add back conflict edges from other nodes to this one
map_conflict
= foldUniqSet
- (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
+ (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
(graphMap graph)
(nodeConflicts node)
-- add back coalesce edges from other nodes to this one
map_coalesce
= foldUniqSet
- (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
+ (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
map_conflict
(nodeCoalesce node)
@@ -434,7 +434,7 @@ freezeNode k
else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
-- If the edge isn't actually in the coelesce set then just ignore it.
- fm2 = foldUniqSet (adjustUFM (freezeEdge k)) fm1
+ fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1
$ nodeCoalesce node
in fm2
@@ -604,7 +604,7 @@ setColor
setColor u color
= graphMapModify
- $ adjustUFM
+ $ adjustUFM_C
(\n -> n { nodeColor = Just color })
u
@@ -621,13 +621,14 @@ adjustWithDefaultUFM f def k map
map
k def
-{-# INLINE adjustUFM #-}
-adjustUFM
+-- Argument order different from UniqFM's adjustUFM
+{-# INLINE adjustUFM_C #-}
+adjustUFM_C
:: Uniquable k
=> (a -> a)
-> k -> UniqFM a -> UniqFM a
-adjustUFM f k map
+adjustUFM_C f k map
= case lookupUFM map k of
Nothing -> map
Just a -> addToUFM map k (f a)
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index e178e99f0d..c4a685b3b5 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -60,7 +60,7 @@ module Outputable (
-- * Error handling and debugging utilities
pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
- pprTrace, warnPprTrace,
+ pprTrace, pprDefiniteTrace, warnPprTrace,
trace, pgmError, panic, sorry, panicFastInt, assertPanic
) where
@@ -800,6 +800,9 @@ pprTrace str doc x
| opt_NoDebugOutput = x
| otherwise = pprAndThen trace str doc x
+pprDefiniteTrace :: String -> SDoc -> a -> a
+-- ^ Same as pprTrace, but show even if -dno-debug-output is on
+pprDefiniteTrace str doc x = pprAndThen trace str doc x
pprPanicFastInt :: String -> SDoc -> FastInt
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index 31d1e878c6..7302b0295e 100644
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -36,6 +36,8 @@ module UniqFM (
addListToUFM,addListToUFM_C,
addToUFM_Directly,
addListToUFM_Directly,
+ adjustUFM,
+ adjustUFM_Directly,
delFromUFM,
delFromUFM_Directly,
delListFromUFM,
@@ -53,12 +55,15 @@ module UniqFM (
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM, keysUFM, splitUFM,
- ufmToList
+ ufmToList,
+ joinUFM
) where
import Unique ( Uniquable(..), Unique, getKey )
import Outputable
+import Compiler.Hoopl hiding (Unique)
+
import qualified Data.IntMap as M
\end{code}
@@ -103,6 +108,9 @@ addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
-> UniqFM elt -> [(key,elt)]
-> UniqFM elt
+adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt
+adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt
+
delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
@@ -175,6 +183,9 @@ addToUFM_Acc exi new (UFM m) k v =
UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)
+adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)
+adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)
+
delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
delListFromUFM = foldl delFromUFM
delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
@@ -207,6 +218,16 @@ keysUFM (UFM m) = map getUnique $ M.keys m
eltsUFM (UFM m) = M.elems m
ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
+-- Hoopl
+joinUFM :: JoinFun v -> JoinFun (UniqFM v)
+joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new
+ where add k new_v (ch, joinmap) =
+ case lookupUFM_Directly joinmap k of
+ Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v)
+ Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
+ (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v')
+ (NoChange, _) -> (ch, joinmap)
+
\end{code}
%************************************************************************
diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index 0e46889ec5..dc4f32ec5e 100644
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -66,6 +66,9 @@ module Util (
-- * Floating point
readRational,
+ -- * read helpers
+ maybeReadFuzzy,
+
-- * IO-ish utilities
createDirectoryHierarchy,
doesDirNameExist,
@@ -966,6 +969,17 @@ readRational top_s
-----------------------------------------------------------------------------
+-- read helpers
+
+maybeReadFuzzy :: Read a => String -> Maybe a
+maybeReadFuzzy str = case reads str of
+ [(x, s)]
+ | all isSpace s ->
+ Just x
+ _ ->
+ Nothing
+
+-----------------------------------------------------------------------------
-- Create a hierarchy of directories
createDirectoryHierarchy :: FilePath -> IO ()
View Lorry Controller Status