diff options
author | Ben Gamari <ben@smart-cactus.org> | 2020-03-29 14:34:54 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-05-13 02:05:11 -0400 |
commit | cb22348fb92411c66f1a39fe2c34b167a9926bc7 (patch) | |
tree | 2b7c30fa23ee09ddc4e894c84e4c5fbce338627f | |
parent | 8c0740b7c38184378aedefdca8fff35707c80de9 (diff) | |
download | haskell-cb22348fb92411c66f1a39fe2c34b167a9926bc7.tar.gz |
Add few cleanups of the CAF logic
Give the NameSet of non-CAFfy names a proper newtype to distinguish it
from all of the other NameSets floating about.
-rw-r--r-- | compiler/GHC/Cmm/Info/Build.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Iface/Make.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Iface/UpdateCafInfos.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Types/Name/Set.hs | 11 |
5 files changed, 23 insertions, 13 deletions
diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index 6eabd638b9..fc3d21e2ca 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -459,7 +459,7 @@ type CAFSet = Set CAFLabel type CAFEnv = LabelMap CAFSet mkCAFLabel :: CLabel -> CAFLabel -mkCAFLabel lbl = CAFLabel $! toClosureLbl lbl +mkCAFLabel lbl = CAFLabel (toClosureLbl lbl) -- This is a label that we can put in an SRT. It *must* be a closure label, -- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR. @@ -736,10 +736,11 @@ getStaticFuns decls = type SRTMap = Map CAFLabel (Maybe SRTEntry) --- | Given SRTMap of a module returns the set of non-CAFFY names in the module. --- Any Names not in the set are CAFFY. -srtMapNonCAFs :: SRTMap -> NameSet -srtMapNonCAFs srtMap = mkNameSet (mapMaybe get_name (Map.toList srtMap)) +-- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the +-- module. Any 'Name's not in the set are CAFFY. +srtMapNonCAFs :: SRTMap -> NonCaffySet +srtMapNonCAFs srtMap = + NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap)) where get_name (CAFLabel l, Nothing) = hasHaskellName l get_name (_l, Just _srt_entry) = Nothing diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index d01264ca55..6cc61246b9 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1384,7 +1384,7 @@ hscWriteIface dflags iface no_change mod_location = do -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath - -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet) + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NonCaffySet) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation. @@ -1541,7 +1541,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs -> [StgTopBinding] -> HpcInfo - -> IO (Stream IO CmmGroupSRTs NameSet) + -> IO (Stream IO CmmGroupSRTs NonCaffySet) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost. diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 15d1c720ea..bb80d5d79b 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -100,7 +100,7 @@ mkPartialIface hsc_env mod_details -- | Fully instantiate a interface -- Adds fingerprints and potentially code generator produced information. -mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface +mkFullIface :: HscEnv -> PartialModIface -> Maybe NonCaffySet -> IO ModIface mkFullIface hsc_env partial_iface mb_non_cafs = do let decls | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env) @@ -117,9 +117,9 @@ mkFullIface hsc_env partial_iface mb_non_cafs = do return full_iface -updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl] +updateDeclCafInfos :: [IfaceDecl] -> Maybe NonCaffySet -> [IfaceDecl] updateDeclCafInfos decls Nothing = decls -updateDeclCafInfos decls (Just non_cafs) = map update_decl decls +updateDeclCafInfos decls (Just (NonCaffySet non_cafs)) = map update_decl decls where update_decl decl | IfaceId nm ty details infos <- decl diff --git a/compiler/GHC/Iface/UpdateCafInfos.hs b/compiler/GHC/Iface/UpdateCafInfos.hs index befb95c6ef..1abe2ee659 100644 --- a/compiler/GHC/Iface/UpdateCafInfos.hs +++ b/compiler/GHC/Iface/UpdateCafInfos.hs @@ -23,7 +23,7 @@ import GHC.Utils.Outputable -- | Update CafInfos of all occurences (in rules, unfoldings, class instances) updateModDetailsCafInfos :: DynFlags - -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY. + -> NonCaffySet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY. -> ModDetails -- ^ ModDetails to update -> ModDetails @@ -31,7 +31,7 @@ updateModDetailsCafInfos dflags _ mod_details | gopt Opt_OmitInterfacePragmas dflags = mod_details -updateModDetailsCafInfos _ non_cafs mod_details = +updateModDetailsCafInfos _ (NonCaffySet non_cafs) mod_details = {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -} let ModDetails{ md_types = type_env -- for unfoldings diff --git a/compiler/GHC/Types/Name/Set.hs b/compiler/GHC/Types/Name/Set.hs index c011bcbf23..73353eaa75 100644 --- a/compiler/GHC/Types/Name/Set.hs +++ b/compiler/GHC/Types/Name/Set.hs @@ -4,6 +4,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Types.Name.Set ( -- * Names set type NameSet, @@ -28,7 +29,10 @@ module GHC.Types.Name.Set ( -- ** Manipulating defs and uses emptyDUs, usesOnly, mkDUs, plusDU, - findUses, duDefs, duUses, allUses + findUses, duDefs, duUses, allUses, + + -- * Non-CAFfy names + NonCaffySet(..) ) where #include "HsVersions.h" @@ -213,3 +217,8 @@ findUses dus uses = rhs_uses `unionNameSet` uses | otherwise -- No def is used = uses + +-- | 'Id's which have no CAF references. This is a result of analysis of C--. +-- It is always safe to use an empty 'NonCaffySet'. TODO Refer to Note. +newtype NonCaffySet = NonCaffySet NameSet + deriving (Semigroup, Monoid) |