summaryrefslogtreecommitdiff
path: root/compiler/utils
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/utils')
-rw-r--r--compiler/utils/Binary.hs141
-rw-r--r--compiler/utils/FastString.lhs67
-rw-r--r--compiler/utils/Maybes.lhs5
-rw-r--r--compiler/utils/Outputable.lhs10
-rw-r--r--compiler/utils/Platform.hs8
-rw-r--r--compiler/utils/Pretty.lhs4
-rw-r--r--compiler/utils/UniqFM.lhs2
-rw-r--r--compiler/utils/UniqSet.lhs3
-rw-r--r--compiler/utils/Util.lhs31
9 files changed, 258 insertions, 13 deletions
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index e07577776a..d14c326d34 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -784,3 +784,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/FastString.lhs b/compiler/utils/FastString.lhs
index 36b1b1e63e..25f98021f4 100644
--- a/compiler/utils/FastString.lhs
+++ b/compiler/utils/FastString.lhs
@@ -120,6 +120,10 @@ import GHC.IO ( IO(..) )
import Foreign.Safe
+#if STAGE >= 2
+import GHC.Conc.Sync (sharedCAF)
+#endif
+
#if defined(__GLASGOW_HASKELL__)
import GHC.Base ( unpackCString# )
#endif
@@ -225,14 +229,63 @@ data FastStringTable =
{-# UNPACK #-} !Int
(MutableArray# RealWorld [FastString])
-{-# 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
+{-# NOINLINE string_table #-}
+string_table = unsafePerformIO $ do
+ tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of
+ (# s2#, arr# #) ->
+ (# s2#, FastStringTable 0 arr# #)
+ ref <- newIORef tab
+ -- use the support wired into the RTS to share this CAF among all images of
+ -- libHSghc
+#if STAGE < 2
+ return ref
+#else
+ sharedCAF ref 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 [FastString]
lookupTbl (FastStringTable _ arr#) (I# i#) =
diff --git a/compiler/utils/Maybes.lhs b/compiler/utils/Maybes.lhs
index 8a612fbb60..859908e266 100644
--- a/compiler/utils/Maybes.lhs
+++ b/compiler/utils/Maybes.lhs
@@ -14,6 +14,7 @@ module Maybes (
mapCatMaybes,
allMaybes,
firstJust, firstJusts,
+ whenIsJust,
expectJust,
maybeToBool,
@@ -68,6 +69,10 @@ mapCatMaybes _ [] = []
mapCatMaybes f (x:xs) = case f x of
Just y -> y : mapCatMaybes f xs
Nothing -> mapCatMaybes f xs
+
+whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenIsJust (Just x) f = f x
+whenIsJust Nothing _ = return ()
\end{code}
\begin{code}
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index bd2a955469..da8ffb3f10 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -90,6 +90,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
@@ -421,7 +422,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
@@ -616,6 +620,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
diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs
index 213a63e0c8..617e691ddf 100644
--- a/compiler/utils/Platform.hs
+++ b/compiler/utils/Platform.hs
@@ -13,6 +13,7 @@ module Platform (
isARM,
osElfTarget,
platformUsesFrameworks,
+ platformBinariesAreStaticLibs,
)
where
@@ -135,3 +136,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..0c8e5fa1d0 100644
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -557,7 +557,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}
diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index 680300abd4..862af99443 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 (
diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.lhs
index ccbd25a4ce..1653f2dc43 100644
--- a/compiler/utils/UniqSet.lhs
+++ b/compiler/utils/UniqSet.lhs
@@ -31,6 +31,7 @@ module UniqSet (
isEmptyUniqSet,
lookupUniqSet,
uniqSetToList,
+ partitionUniqSet
) where
import UniqFM
@@ -67,6 +68,7 @@ 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
@@ -106,6 +108,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
View Lorry Controller Status