[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Fix GHCis interaction with tag inference.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Oct 18 03:25:08 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b4b304b4 by Andreas Klebinger at 2022-10-17T23:24:26-04:00
Fix GHCis interaction with tag inference.
I had assumed that wrappers were not inlined in interactive mode.
Meaning we would always execute the compiled wrapper which properly
takes care of upholding the strict field invariant.
This turned out to be wrong. So instead we now run tag inference even
when we generate bytecode. In that case only for correctness not
performance reasons although it will be still beneficial for runtime
in some cases.
I further fixed a bug where GHCi didn't tag nullary constructors
properly when used as arguments. Which caused segfaults when calling
into compiled functions which expect the strict field invariant to
be upheld.
Fixes #22042 and #21083
-------------------------
Metric Increase:
T4801
Metric Decrease:
T13035
-------------------------
- - - - -
cda589dd by M Farkas-Dyck at 2022-10-17T23:24:34-04:00
Make `Functor` a superclass of `TrieMap`, which lets us derive the `map` functions.
- - - - -
60f6ec99 by Ben Gamari at 2022-10-17T23:24:35-04:00
configure: Bump minimum bootstrap GHC version
Fixes #22245
- - - - -
7093c407 by Matthew Pickering at 2022-10-17T23:24:36-04:00
Build System: Remove out-of-date comment about make build system
Both make and hadrian interleave compilation of modules of different
modules and don't respect the package boundaries. Therefore I just
remove this comment which points out this "difference".
Fixes #22253
- - - - -
255437e5 by Jan Hrček at 2022-10-17T23:24:38-04:00
Small language fixes in 'Using GHC'
- - - - -
27 changed files:
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/Core/Map/Expr.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Data/TrieMap.hs
- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Stg/CSE.hs
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Stg/InferTags/TagSig.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Types.hs
- compiler/GHC/Types/Name/Set.hs
- configure.ac
- docs/users_guide/using.rst
- libraries/base/GHC/Base.hs
- testsuite/tests/ghci.debugger/scripts/T12458.stdout
- testsuite/tests/ghci.debugger/scripts/print018.stdout
- testsuite/tests/simplStg/should_run/Makefile
- + testsuite/tests/simplStg/should_run/T22042.hs
- + testsuite/tests/simplStg/should_run/T22042.stdout
- + testsuite/tests/simplStg/should_run/T22042a.hs
- testsuite/tests/simplStg/should_run/all.T
Changes:
=====================================
compiler/GHC/Cmm/Dataflow/Label.hs
=====================================
@@ -140,7 +140,6 @@ instance TrieMap LabelMap where
lookupTM k m = mapLookup k m
alterTM k f m = mapAlter f k m
foldTM k m z = mapFoldr k z m
- mapTM f m = mapMap f m
filterTM f m = mapFilter f m
-----------------------------------------------------------------------------
=====================================
compiler/GHC/Core/Map/Expr.hs
=====================================
@@ -109,13 +109,17 @@ See also Note [Empty case alternatives] in GHC.Core.
-- is the type you want.
newtype CoreMap a = CoreMap (CoreMapG a)
+-- TODO(22292): derive
+instance Functor CoreMap where
+ fmap f = \ (CoreMap m) -> CoreMap (fmap f m)
+ {-# INLINE fmap #-}
+
instance TrieMap CoreMap where
type Key CoreMap = CoreExpr
emptyTM = CoreMap emptyTM
lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m
alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)
foldTM k (CoreMap m) = foldTM k m
- mapTM f (CoreMap m) = CoreMap (mapTM f m)
filterTM f (CoreMap m) = CoreMap (filterTM f m)
-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a at . The extended
@@ -248,30 +252,27 @@ emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM
, cm_letr = emptyTM, cm_case = emptyTM
, cm_ecase = emptyTM, cm_tick = emptyTM }
+-- TODO(22292): derive
+instance Functor CoreMapX where
+ fmap f CM
+ { cm_var = cvar, cm_lit = clit, cm_co = cco, cm_type = ctype, cm_cast = ccast
+ , cm_app = capp, cm_lam = clam, cm_letn = cletn, cm_letr = cletr, cm_case = ccase
+ , cm_ecase = cecase, cm_tick = ctick } = CM
+ { cm_var = fmap f cvar, cm_lit = fmap f clit, cm_co = fmap f cco, cm_type = fmap f ctype
+ , cm_cast = fmap (fmap f) ccast, cm_app = fmap (fmap f) capp, cm_lam = fmap (fmap f) clam
+ , cm_letn = fmap (fmap (fmap f)) cletn, cm_letr = fmap (fmap (fmap f)) cletr
+ , cm_case = fmap (fmap f) ccase, cm_ecase = fmap (fmap f) cecase
+ , cm_tick = fmap (fmap f) ctick }
+
instance TrieMap CoreMapX where
type Key CoreMapX = DeBruijn CoreExpr
emptyTM = emptyE
lookupTM = lkE
alterTM = xtE
foldTM = fdE
- mapTM = mapE
filterTM = ftE
--------------------------
-mapE :: (a->b) -> CoreMapX a -> CoreMapX b
-mapE f (CM { cm_var = cvar, cm_lit = clit
- , cm_co = cco, cm_type = ctype
- , cm_cast = ccast , cm_app = capp
- , cm_lam = clam, cm_letn = cletn
- , cm_letr = cletr, cm_case = ccase
- , cm_ecase = cecase, cm_tick = ctick })
- = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit
- , cm_co = mapTM f cco, cm_type = mapTM f ctype
- , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp
- , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn
- , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase
- , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }
-
ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a
ftE f (CM { cm_var = cvar, cm_lit = clit
, cm_co = cco, cm_type = ctype
@@ -281,10 +282,10 @@ ftE f (CM { cm_var = cvar, cm_lit = clit
, cm_ecase = cecase, cm_tick = ctick })
= CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit
, cm_co = filterTM f cco, cm_type = filterTM f ctype
- , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp
- , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn
- , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase
- , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }
+ , cm_cast = fmap (filterTM f) ccast, cm_app = fmap (filterTM f) capp
+ , cm_lam = fmap (filterTM f) clam, cm_letn = fmap (fmap (filterTM f)) cletn
+ , cm_letr = fmap (fmap (filterTM f)) cletr, cm_case = fmap (filterTM f) ccase
+ , cm_ecase = fmap (filterTM f) cecase, cm_tick = fmap (filterTM f) ctick }
--------------------------
lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a
@@ -394,6 +395,11 @@ data AltMap a -- A single alternative
, am_data :: DNameEnv (CoreMapG a)
, am_lit :: LiteralMap (CoreMapG a) }
+-- TODO(22292): derive
+instance Functor AltMap where
+ fmap f AM { am_deflt = adeflt, am_data = adata, am_lit = alit } = AM
+ { am_deflt = fmap f adeflt, am_data = fmap (fmap f) adata, am_lit = fmap (fmap f) alit }
+
instance TrieMap AltMap where
type Key AltMap = CoreAlt
emptyTM = AM { am_deflt = emptyTM
@@ -402,7 +408,6 @@ instance TrieMap AltMap where
lookupTM = lkA emptyCME
alterTM = xtA emptyCME
foldTM = fdA
- mapTM = mapA
filterTM = ftA
instance Eq (DeBruijn CoreAlt) where
@@ -416,17 +421,11 @@ instance Eq (DeBruijn CoreAlt) where
D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2
go _ _ = False
-mapA :: (a->b) -> AltMap a -> AltMap b
-mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
- = AM { am_deflt = mapTM f adeflt
- , am_data = mapTM (mapTM f) adata
- , am_lit = mapTM (mapTM f) alit }
-
ftA :: (a->Bool) -> AltMap a -> AltMap a
ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
= AM { am_deflt = filterTM f adeflt
- , am_data = mapTM (filterTM f) adata
- , am_lit = mapTM (filterTM f) alit }
+ , am_data = fmap (filterTM f) adata
+ , am_lit = fmap (filterTM f) alit }
lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs)
=====================================
compiler/GHC/Core/Map/Type.hs
=====================================
@@ -83,25 +83,33 @@ import GHC.Data.Maybe
-- just look up the coercion's type.
newtype CoercionMap a = CoercionMap (CoercionMapG a)
+-- TODO(22292): derive
+instance Functor CoercionMap where
+ fmap f = \ (CoercionMap m) -> CoercionMap (fmap f m)
+ {-# INLINE fmap #-}
+
instance TrieMap CoercionMap where
type Key CoercionMap = Coercion
emptyTM = CoercionMap emptyTM
lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m
alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)
foldTM k (CoercionMap m) = foldTM k m
- mapTM f (CoercionMap m) = CoercionMap (mapTM f m)
filterTM f (CoercionMap m) = CoercionMap (filterTM f m)
type CoercionMapG = GenMap CoercionMapX
newtype CoercionMapX a = CoercionMapX (TypeMapX a)
+-- TODO(22292): derive
+instance Functor CoercionMapX where
+ fmap f = \ (CoercionMapX core_tm) -> CoercionMapX (fmap f core_tm)
+ {-# INLINE fmap #-}
+
instance TrieMap CoercionMapX where
type Key CoercionMapX = DeBruijn Coercion
emptyTM = CoercionMapX emptyTM
lookupTM = lkC
alterTM = xtC
foldTM f (CoercionMapX core_tm) = foldTM f core_tm
- mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm)
filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm)
instance Eq (DeBruijn Coercion) where
@@ -172,13 +180,21 @@ trieMapView ty
| Just ty' <- tcView ty = Just ty'
trieMapView _ = Nothing
+-- TODO(22292): derive
+instance Functor TypeMapX where
+ fmap f TM
+ { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon, tm_funty = tfunty, tm_forall = tforall
+ , tm_tylit = tlit, tm_coerce = tcoerce } = TM
+ { tm_var = fmap f tvar, tm_app = fmap (fmap f) tapp, tm_tycon = fmap f ttycon
+ , tm_funty = fmap (fmap (fmap f)) tfunty, tm_forall = fmap (fmap f) tforall
+ , tm_tylit = fmap f tlit, tm_coerce = fmap f tcoerce }
+
instance TrieMap TypeMapX where
type Key TypeMapX = DeBruijn Type
emptyTM = emptyT
lookupTM = lkT
alterTM = xtT
foldTM = fdT
- mapTM = mapT
filterTM = filterT
instance Eq (DeBruijn Type) where
@@ -313,18 +329,6 @@ emptyT = TM { tm_var = emptyTM
, tm_tylit = emptyTyLitMap
, tm_coerce = Nothing }
-mapT :: (a->b) -> TypeMapX a -> TypeMapX b
-mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon
- , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit
- , tm_coerce = tcoerce })
- = TM { tm_var = mapTM f tvar
- , tm_app = mapTM (mapTM f) tapp
- , tm_tycon = mapTM f ttycon
- , tm_funty = mapTM (mapTM (mapTM f)) tfunty
- , tm_forall = mapTM (mapTM f) tforall
- , tm_tylit = mapTM f tlit
- , tm_coerce = fmap f tcoerce }
-
-----------------
lkT :: DeBruijn Type -> TypeMapX a -> Maybe a
lkT (D env ty) m = go ty m
@@ -382,10 +386,10 @@ filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon
, tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit
, tm_coerce = tcoerce })
= TM { tm_var = filterTM f tvar
- , tm_app = mapTM (filterTM f) tapp
+ , tm_app = fmap (filterTM f) tapp
, tm_tycon = filterTM f ttycon
- , tm_funty = mapTM (mapTM (filterTM f)) tfunty
- , tm_forall = mapTM (filterTM f) tforall
+ , tm_funty = fmap (fmap (filterTM f)) tfunty
+ , tm_forall = fmap (filterTM f) tforall
, tm_tylit = filterTM f tlit
, tm_coerce = filterMaybe f tcoerce }
@@ -395,22 +399,22 @@ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
, tlm_char :: Map.Map Char a
}
+-- TODO(22292): derive
+instance Functor TyLitMap where
+ fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM
+ { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc }
+
instance TrieMap TyLitMap where
type Key TyLitMap = TyLit
emptyTM = emptyTyLitMap
lookupTM = lkTyLit
alterTM = xtTyLit
foldTM = foldTyLit
- mapTM = mapTyLit
filterTM = filterTyLit
emptyTyLitMap :: TyLitMap a
emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty }
-mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b
-mapTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
- = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc }
-
lkTyLit :: TyLit -> TyLitMap a -> Maybe a
lkTyLit l =
case l of
@@ -439,6 +443,11 @@ filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
-- is the type you want. The keys in this map may have different kinds.
newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a))
+-- TODO(22292): derive
+instance Functor TypeMap where
+ fmap f = \ (TypeMap m) -> TypeMap (fmap (fmap f) m)
+ {-# INLINE fmap #-}
+
lkTT :: DeBruijn Type -> TypeMap a -> Maybe a
lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m
>>= lkG (D env ty)
@@ -456,8 +465,7 @@ instance TrieMap TypeMap where
lookupTM k m = lkTT (deBruijnize k) m
alterTM k f m = xtTT (deBruijnize k) f m
foldTM k (TypeMap m) = foldTM (foldTM k) m
- mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m)
- filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) m)
+ filterTM f (TypeMap m) = TypeMap (fmap (filterTM f) m)
foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap k z m = foldTM k m z
@@ -488,8 +496,12 @@ mkDeBruijnContext = extendCMEs emptyCME
-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g),
-- you'll find entries inserted under (t), even if (g) is non-reflexive.
-newtype LooseTypeMap a
- = LooseTypeMap (TypeMapG a)
+newtype LooseTypeMap a = LooseTypeMap (TypeMapG a)
+
+-- TODO(22292): derive
+instance Functor LooseTypeMap where
+ fmap f = \ (LooseTypeMap m) -> LooseTypeMap (fmap f m)
+ {-# INLINE fmap #-}
instance TrieMap LooseTypeMap where
type Key LooseTypeMap = Type
@@ -497,7 +509,6 @@ instance TrieMap LooseTypeMap where
lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m
alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)
foldTM f (LooseTypeMap m) = foldTM f m
- mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)
filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m)
{-
@@ -566,18 +577,19 @@ instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where
-- of pairs are composition.
data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a))
+-- TODO(22292): derive
+instance Functor BndrMap where
+ fmap f = \ (BndrMap tm) -> BndrMap (fmap (fmap f) tm)
+ {-# INLINE fmap #-}
+
instance TrieMap BndrMap where
type Key BndrMap = Var
emptyTM = BndrMap emptyTM
lookupTM = lkBndr emptyCME
alterTM = xtBndr emptyCME
foldTM = fdBndrMap
- mapTM = mapBndrMap
filterTM = ftBndrMap
-mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b
-mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm)
-
fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b
fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm
@@ -596,25 +608,24 @@ xtBndr env v xt (BndrMap tymap) =
BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt))
ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a
-ftBndrMap f (BndrMap tm) = BndrMap (mapTM (filterTM f) tm)
+ftBndrMap f (BndrMap tm) = BndrMap (fmap (filterTM f) tm)
--------- Variable occurrence -------------
data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable
, vm_fvar :: DVarEnv a } -- Free variable
+-- TODO(22292): derive
+instance Functor VarMap where
+ fmap f VM { vm_bvar = bv, vm_fvar = fv } = VM { vm_bvar = fmap f bv, vm_fvar = fmap f fv }
+
instance TrieMap VarMap where
type Key VarMap = Var
emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv }
lookupTM = lkVar emptyCME
alterTM = xtVar emptyCME
foldTM = fdVar
- mapTM = mapVar
filterTM = ftVar
-mapVar :: (a->b) -> VarMap a -> VarMap b
-mapVar f (VM { vm_bvar = bv, vm_fvar = fv })
- = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv }
-
lkVar :: CmEnv -> Var -> VarMap a -> Maybe a
lkVar env v
| Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv
=====================================
compiler/GHC/Data/TrieMap.hs
=====================================
@@ -66,12 +66,11 @@ Structures", Section 10.3.2
type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing)
-- or an existing elt (Just)
-class TrieMap m where
+class Functor m => TrieMap m where
type Key m :: Type
emptyTM :: m a
lookupTM :: forall b. Key m -> m b -> Maybe b
alterTM :: forall b. Key m -> XT b -> m b -> m b
- mapTM :: (a->b) -> m a -> m b
filterTM :: (a -> Bool) -> m a -> m a
foldTM :: (a -> b -> b) -> m a -> b -> b
@@ -116,6 +115,25 @@ deMaybe :: TrieMap m => Maybe (m a) -> m a
deMaybe Nothing = emptyTM
deMaybe (Just m) = m
+{-
+Note [Every TrieMap is a Functor]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Every TrieMap T admits
+ fmap :: (a->b) -> T a -> T b
+where (fmap f t) applies `f` to every element of the range of `t`.
+Ergo, we make `Functor` a superclass of `TrieMap`.
+
+Moreover it is almost invariably possible to /derive/ Functor for each
+particular instance. E.g. in the list instance we have
+ data ListMap m a
+ = LM { lm_nil :: Maybe a
+ , lm_cons :: m (ListMap m a) }
+ deriving (Functor)
+ instance TrieMap m => TrieMap (ListMap m) where { .. }
+
+Alas, we not yet derive `Functor` for reasons of performance; see #22292.
+-}
+
{-
************************************************************************
* *
@@ -130,7 +148,6 @@ instance TrieMap IntMap.IntMap where
lookupTM k m = IntMap.lookup k m
alterTM = xtInt
foldTM k m z = IntMap.foldr k z m
- mapTM f m = IntMap.map f m
filterTM f m = IntMap.filter f m
xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a
@@ -142,7 +159,6 @@ instance Ord k => TrieMap (Map.Map k) where
lookupTM = Map.lookup
alterTM k f m = Map.alter f k m
foldTM k m z = Map.foldr k z m
- mapTM f m = Map.map f m
filterTM f m = Map.filter f m
@@ -219,7 +235,6 @@ instance forall key. Uniquable key => TrieMap (UniqDFM key) where
lookupTM k m = lookupUDFM m k
alterTM k f m = alterUDFM f m k
foldTM k m z = foldUDFM k z m
- mapTM f m = mapUDFM f m
filterTM f m = filterUDFM f m
{-
@@ -235,22 +250,22 @@ then (MaybeMap m) is a map from (Maybe k) -> val
data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a }
+-- TODO(22292): derive
+instance Functor m => Functor (MaybeMap m) where
+ fmap f MM { mm_nothing = mn, mm_just = mj } = MM
+ { mm_nothing = fmap f mn, mm_just = fmap f mj }
+
instance TrieMap m => TrieMap (MaybeMap m) where
type Key (MaybeMap m) = Maybe (Key m)
emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM }
lookupTM = lkMaybe lookupTM
alterTM = xtMaybe alterTM
foldTM = fdMaybe
- mapTM = mapMb
filterTM = ftMaybe
instance TrieMap m => Foldable (MaybeMap m) where
foldMap = foldMapTM
-mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b
-mapMb f (MM { mm_nothing = mn, mm_just = mj })
- = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj }
-
lkMaybe :: (forall b. k -> m b -> Maybe b)
-> Maybe k -> MaybeMap m a -> Maybe a
lkMaybe _ Nothing = mm_nothing
@@ -290,13 +305,17 @@ data ListMap m a
= LM { lm_nil :: Maybe a
, lm_cons :: m (ListMap m a) }
+-- TODO(22292): derive
+instance Functor m => Functor (ListMap m) where
+ fmap f LM { lm_nil = mnil, lm_cons = mcons } = LM
+ { lm_nil = fmap f mnil, lm_cons = fmap (fmap f) mcons }
+
instance TrieMap m => TrieMap (ListMap m) where
type Key (ListMap m) = [Key m]
emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM }
lookupTM = lkList lookupTM
alterTM = xtList alterTM
foldTM = fdList
- mapTM = mapList
filterTM = ftList
instance TrieMap m => Foldable (ListMap m) where
@@ -305,10 +324,6 @@ instance TrieMap m => Foldable (ListMap m) where
instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where
ppr m = text "List elts" <+> ppr (foldTM (:) m [])
-mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b
-mapList f (LM { lm_nil = mnil, lm_cons = mcons })
- = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons }
-
lkList :: TrieMap m => (forall b. k -> m b -> Maybe b)
-> [k] -> ListMap m a -> Maybe a
lkList _ [] = lm_nil
@@ -326,7 +341,7 @@ fdList k m = foldMaybe k (lm_nil m)
ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a
ftList f (LM { lm_nil = mnil, lm_cons = mcons })
- = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons }
+ = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons }
{-
************************************************************************
@@ -380,6 +395,11 @@ instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where
ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v
ppr (MultiMap m) = ppr m
+-- TODO(22292): derive
+instance Functor m => Functor (GenMap m) where
+ fmap = mapG
+ {-# INLINE fmap #-}
+
-- TODO undecidable instance
instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where
type Key (GenMap m) = Key m
@@ -387,7 +407,6 @@ instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where
lookupTM = lkG
alterTM = xtG
foldTM = fdG
- mapTM = mapG
filterTM = ftG
instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where
@@ -431,10 +450,10 @@ xtG k f m@(SingletonMap k' v')
xtG k f (MultiMap m) = MultiMap (alterTM k f m)
{-# INLINEABLE mapG #-}
-mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b
+mapG :: Functor m => (a -> b) -> GenMap m a -> GenMap m b
mapG _ EmptyMap = EmptyMap
mapG f (SingletonMap k v) = SingletonMap k (f v)
-mapG f (MultiMap m) = MultiMap (mapTM f m)
+mapG f (MultiMap m) = MultiMap (fmap f m)
{-# INLINEABLE fdG #-}
fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b
=====================================
compiler/GHC/Driver/GenerateCgIPEStub.hs
=====================================
@@ -26,11 +26,9 @@ import GHC.Runtime.Heap.Layout (isStackRep)
import GHC.Settings (Platform, platformUnregisterised)
import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState)
import GHC.StgToCmm.Prof (initInfoTableProv)
-import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
-import GHC.Stg.InferTags.TagSig (TagSig)
+import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)
import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)
import GHC.Types.Name.Set (NonCaffySet)
-import GHC.Types.Name.Env (NameEnv)
import GHC.Types.Tickish (GenTickish (SourceNote))
import GHC.Unit.Types (Module)
import GHC.Utils.Misc
@@ -180,8 +178,8 @@ The find the tick:
remembered in a `Maybe`.
-}
-generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> NameEnv TagSig -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos
-generateCgIPEStub hsc_env this_mod denv tag_sigs s = do
+generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CmmCgInfos
+generateCgIPEStub hsc_env this_mod denv s = do
let dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
logger = hsc_logger hsc_env
@@ -200,7 +198,7 @@ generateCgIPEStub hsc_env this_mod denv tag_sigs s = do
(_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup
Stream.yield ipeCmmGroupSRTs
- return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = tag_sigs}
+ return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub}
where
collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)
collect platform acc cmmGroupSRTs = do
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -192,15 +192,14 @@ import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) )
import GHC.Stg.Syntax
-import GHC.Stg.Pipeline ( stg2stg )
-import GHC.Stg.InferTags
+import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )
import GHC.Builtin.Utils
import GHC.Builtin.Names
import GHC.Builtin.Uniques ( mkPseudoUniqueE )
import qualified GHC.StgToCmm as StgToCmm ( codeGen )
-import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
+import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)
import GHC.Cmm
import GHC.Cmm.Info.Build
@@ -281,6 +280,8 @@ import Data.Time
import System.IO.Unsafe ( unsafeInterleaveIO )
import GHC.Iface.Env ( trace_if )
+import GHC.Stg.InferTags.TagSig (seqTagSig)
+import GHC.Types.Unique.FM
{- **********************************************************************
@@ -1770,7 +1771,7 @@ hscSimpleIface' mb_core_program tc_result summary = do
-- | Compile to hard-code.
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
- -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe CgInfos)
+ -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
-- ^ @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.
@@ -1820,11 +1821,16 @@ hscGenHardCode hsc_env cgguts location output_filename = do
this_mod location late_cc_binds data_tycons
----------------- Convert to STG ------------------
- (stg_binds, denv, (caf_ccs, caf_cc_stacks))
+ (stg_binds, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)
<- {-# SCC "CoreToStg" #-}
withTiming logger
(text "CoreToStg"<+>brackets (ppr this_mod))
- (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())
+ (\(a, b, (c,d), tag_env) ->
+ a `seqList`
+ b `seq`
+ c `seqList`
+ d `seqList`
+ (seqEltsUFM (seqTagSig) tag_env))
(myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)
let cost_centre_info =
@@ -1863,11 +1869,12 @@ hscGenHardCode hsc_env cgguts location output_filename = do
let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init
`appendStubC` cgIPEStub st
- (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)
+ (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)
<- {-# SCC "codeOutput" #-}
codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location
foreign_stubs foreign_files dependencies rawcmms1
- return (output_filename, stub_c_exists, foreign_fps, Just cg_infos)
+ return ( output_filename, stub_c_exists, foreign_fps
+ , Just stg_cg_infos, Just cmm_cg_infos)
-- The part of CgGuts that we need for HscInteractive
@@ -1915,7 +1922,9 @@ hscInteractive hsc_env cgguts location = do
(initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
this_mod location core_binds data_tycons
- (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+ -- The stg cg info only provides a runtime benfit, but is not requires so we just
+ -- omit it here
+ (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)
<- {-# SCC "CoreToStg" #-}
myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds
----------------- Generate byte code ------------------
@@ -2036,7 +2045,7 @@ doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
-> HpcInfo
- -> IO (Stream IO CmmGroupSRTs CgInfos)
+ -> IO (Stream IO CmmGroupSRTs CmmCgInfos)
-- 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.
@@ -2047,13 +2056,10 @@ doCodeGen hsc_env this_mod denv data_tycons
hooks = hsc_hooks hsc_env
tmpfs = hsc_tmpfs hsc_env
platform = targetPlatform dflags
-
- -- Do tag inference on optimized STG
- (!stg_post_infer,export_tag_info) <-
- {-# SCC "StgTagFields" #-} inferTags dflags logger this_mod stg_binds_w_fvs
+ stg_ppr_opts = (initStgPprOpts dflags)
putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
- (pprGenStgTopBindings (initStgPprOpts dflags) stg_post_infer)
+ (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs)
let stg_to_cmm dflags mod = case stgToCmmHook hooks of
Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)
@@ -2061,8 +2067,8 @@ doCodeGen hsc_env this_mod denv data_tycons
let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
-- See Note [Forcing of stg_binds]
- cmm_stream = stg_post_infer `seqList` {-# SCC "StgToCmm" #-}
- stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_post_infer hpc_info
+ cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
+ stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info
-- codegen consumes a stream of CmmGroup, and produces a new
-- stream of CmmGroup (not necessarily synchronised: one
@@ -2093,7 +2099,7 @@ doCodeGen hsc_env this_mod denv data_tycons
putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)
return a
- return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv export_tag_info pipeline_stream
+ return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream
myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
-> Bool
@@ -2101,7 +2107,8 @@ myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
-> IO ( Id
, [CgStgTopBinding]
, InfoTableProvMap
- , CollectedCCs )
+ , CollectedCCs
+ , StgCgInfos )
myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
{- Create a temporary binding (just because myCoreToStg needs a
binding for the stg2stg step) -}
@@ -2109,7 +2116,7 @@ myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
(mkPseudoUniqueE 0)
Many
(exprType prepd_expr)
- (stg_binds, prov_map, collected_ccs) <-
+ (stg_binds, prov_map, collected_ccs, stg_cg_infos) <-
myCoreToStg logger
dflags
ictxt
@@ -2117,20 +2124,21 @@ myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
this_mod
ml
[NonRec bco_tmp_id prepd_expr]
- return (bco_tmp_id, stg_binds, prov_map, collected_ccs)
+ return (bco_tmp_id, stg_binds, prov_map, collected_ccs, stg_cg_infos)
myCoreToStg :: Logger -> DynFlags -> InteractiveContext
-> Bool
-> Module -> ModLocation -> CoreProgram
-> IO ( [CgStgTopBinding] -- output program
, InfoTableProvMap
- , CollectedCCs ) -- CAF cost centre info (declared and used)
+ , CollectedCCs -- CAF cost centre info (declared and used)
+ , StgCgInfos )
myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
let (stg_binds, denv, cost_centre_info)
= {-# SCC "Core2Stg" #-}
coreToStg dflags this_mod ml prepd_binds
- stg_binds_with_fvs
+ (stg_binds_with_fvs,stg_cg_info)
<- {-# SCC "Stg2Stg" #-}
stg2stg logger (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode)
this_mod stg_binds
@@ -2138,7 +2146,7 @@ myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG
(pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs)
- return (stg_binds_with_fvs, denv, cost_centre_info)
+ return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info)
{- **********************************************************************
%* *
@@ -2289,7 +2297,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
(initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
this_mod iNTERACTIVELoc core_binds data_tycons
- (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+ (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info)
<- {-# SCC "CoreToStg" #-}
liftIO $ myCoreToStg (hsc_logger hsc_env)
(hsc_dflags hsc_env)
@@ -2527,7 +2535,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" }
; let ictxt = hsc_IC hsc_env
- ; (binding_id, stg_expr, _, _) <-
+ ; (binding_id, stg_expr, _, _, _stg_cg_info) <-
myCoreToStgExpr logger
dflags
ictxt
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -742,7 +742,7 @@ hscBackendPipeline pipe_env hsc_env mod_sum result =
else
case result of
HscUpdate iface -> return (iface, emptyHomeModInfoLinkable)
- HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure emptyHomeModInfoLinkable
+ HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure emptyHomeModInfoLinkable
-- TODO: Why is there not a linkable?
-- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -536,10 +536,10 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
else if backendWritesFiles (backend dflags) then
do
output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
- (outputFilename, mStub, foreign_files, cg_infos) <-
+ (outputFilename, mStub, foreign_files, stg_infos, cg_infos) <-
hscGenHardCode hsc_env cgguts mod_location output_fn
- final_iface <- mkFullIface hsc_env partial_iface cg_infos
+ final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos
-- See Note [Writing interface files]
hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
@@ -567,7 +567,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
-- In interpreted mode the regular codeGen backend is not run so we
-- generate a interface without codeGen info.
do
- final_iface <- mkFullIface hsc_env partial_iface Nothing
+ final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing
hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location
bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location
return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } , panic "interpreter")
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -23,7 +23,7 @@ import GHC.Prelude
import GHC.Hs
-import GHC.StgToCmm.Types (CgInfos (..))
+import GHC.StgToCmm.Types (CmmCgInfos (..))
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Monad
@@ -99,6 +99,7 @@ import Data.Function
import Data.List ( findIndex, mapAccumL, sortBy )
import Data.Ord
import Data.IORef
+import GHC.Stg.Pipeline (StgCgInfos)
{-
@@ -135,16 +136,16 @@ mkPartialIface hsc_env core_prog mod_details mod_summary
-- | Fully instantiate an interface. Adds fingerprints and potentially code
-- generator produced information.
--
--- CgInfos is not available when not generating code (-fno-code), or when not
+-- CmmCgInfos is not available when not generating code (-fno-code), or when not
-- generating interface pragmas (-fomit-interface-pragmas). See also
-- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types.
-mkFullIface :: HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface
-mkFullIface hsc_env partial_iface mb_cg_infos = do
+mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> IO ModIface
+mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos = do
let decls
| gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
= mi_decls partial_iface
| otherwise
- = updateDecl (mi_decls partial_iface) mb_cg_infos
+ = updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos
full_iface <-
{-# SCC "addFingerprints" #-}
@@ -157,11 +158,16 @@ mkFullIface hsc_env partial_iface mb_cg_infos = do
return full_iface
-updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl]
-updateDecl decls Nothing = decls
-updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos, cgTagSigs = tag_sigs })
+updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl]
+updateDecl decls Nothing Nothing = decls
+updateDecl decls m_stg_infos m_cmm_infos
= map update_decl decls
where
+ (non_cafs,lf_infos) = maybe (mempty, mempty)
+ (\cmm_info -> (ncs_nameSet (cgNonCafs cmm_info), cgLFInfos cmm_info))
+ m_cmm_infos
+ tag_sigs = fromMaybe mempty m_stg_infos
+
update_decl (IfaceId nm ty details infos)
| let not_caffy = elemNameSet nm non_cafs
, let mb_lf_info = lookupNameEnv lf_infos nm
@@ -179,6 +185,9 @@ updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf
update_decl decl
= decl
+
+
+
-- | Make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any
-- object code at all ('NoBackend').
@@ -237,7 +246,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program
docs mod_summary
mod_details
- mkFullIface hsc_env partial_iface Nothing
+ mkFullIface hsc_env partial_iface Nothing Nothing
mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource
-> Bool -> Dependencies -> GlobalRdrEnv
=====================================
compiler/GHC/Stg/CSE.hs
=====================================
@@ -117,6 +117,11 @@ data StgArgMap a = SAM
, sam_lit :: LiteralMap a
}
+-- TODO(22292): derive
+instance Functor StgArgMap where
+ fmap f SAM { sam_var = varm, sam_lit = litm } = SAM
+ { sam_var = fmap f varm, sam_lit = fmap f litm }
+
instance TrieMap StgArgMap where
type Key StgArgMap = StgArg
emptyTM = SAM { sam_var = emptyTM
@@ -126,13 +131,16 @@ instance TrieMap StgArgMap where
alterTM (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }
alterTM (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }
foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)
- mapTM f (SAM {sam_var = varm, sam_lit = litm}) =
- SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }
filterTM f (SAM {sam_var = varm, sam_lit = litm}) =
SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm }
newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }
+-- TODO(22292): derive
+instance Functor ConAppMap where
+ fmap f = CAM . fmap (fmap f) . un_cam
+ {-# INLINE fmap #-}
+
instance TrieMap ConAppMap where
type Key ConAppMap = (DataCon, [StgArg])
emptyTM = CAM emptyTM
@@ -140,8 +148,7 @@ instance TrieMap ConAppMap where
alterTM (dataCon, args) f m =
m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
foldTM k = un_cam >.> foldTM (foldTM k)
- mapTM f = un_cam >.> mapTM (mapTM f) >.> CAM
- filterTM f = un_cam >.> mapTM (filterTM f) >.> CAM
+ filterTM f = un_cam >.> fmap (filterTM f) >.> CAM
-----------------
-- The CSE Env --
=====================================
compiler/GHC/Stg/InferTags.hs
=====================================
@@ -27,7 +27,6 @@ import GHC.Stg.InferTags.Types
import GHC.Stg.InferTags.Rewrite (rewriteTopBinds)
import Data.Maybe
import GHC.Types.Name.Env (mkNameEnv, NameEnv)
-import GHC.Driver.Config.Stg.Ppr
import GHC.Driver.Session
import GHC.Utils.Logger
import qualified GHC.Unit.Types
@@ -217,17 +216,17 @@ the output of itself.
-- -> CollectedCCs
-- -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
-- -> HpcInfo
--- -> IO (Stream IO CmmGroupSRTs CgInfos)
+-- -> IO (Stream IO CmmGroupSRTs CmmCgInfos)
-- -- 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.
-inferTags :: DynFlags -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)
-inferTags dflags logger this_mod stg_binds = do
+inferTags :: StgPprOpts -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)
+inferTags ppr_opts logger this_mod stg_binds = do
-- Annotate binders with tag information.
let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}
inferTagsAnal stg_binds
- putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_tags)
+ putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags)
let export_tag_info = collectExportInfo stg_binds_w_tags
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -30,7 +30,7 @@ import GHC.Types.Unique.Supply
import GHC.Types.Unique.FM
import GHC.Types.RepType
import GHC.Types.Var.Set
-import GHC.Unit.Types ( Module )
+import GHC.Unit.Types
import GHC.Core.DataCon
import GHC.Core ( AltCon(..) )
@@ -215,9 +215,49 @@ withLcl fv act = do
setFVs old_fvs
return r
+{- Note [Tag inference for interactive contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When compiling bytecode we call myCoreToStg to get STG code first.
+myCoreToStg in turn calls out to stg2stg which runs the STG to STG
+passes followed by free variables analysis and the tag inference pass including
+it's rewriting phase at the end.
+Running tag inference is important as it upholds Note [Strict Field Invariant].
+While code executed by GHCi doesn't take advantage of the SFI it can call into
+compiled code which does. So it must still make sure that the SFI is upheld.
+See also #21083 and #22042.
+
+However there one important difference in code generation for GHCi and regular
+compilation. When compiling an entire module (not a GHCi expression), we call
+`stg2stg` on the entire module which allows us to build up a map which is guaranteed
+to have an entry for every binder in the current module.
+For non-interactive compilation the tag inference rewrite pass takes advantage
+of this by building up a map from binders to their tag signatures.
+
+When compiling a GHCi expression on the other hand we invoke stg2stg separately
+for each expression on the prompt. This means in GHCi for a sequence of:
+ > let x = True
+ > let y = StrictJust x
+We first run stg2stg for `[x = True]`. And then again for [y = StrictJust x]`.
+
+While computing the tag signature for `y` during tag inference inferConTag will check
+if `x` is already tagged by looking up the tagsig of `x` in the binder->signature mapping.
+However since this mapping isn't persistent between stg2stg
+invocations the lookup will fail. This isn't a correctness issue since it's always
+safe to assume a binding isn't tagged and that's what we do in such cases.
+
+However for non-interactive mode we *don't* want to do this. Since in non-interactive mode
+we have all binders of the module available for each invocation we can expect the binder->signature
+mapping to be complete and all lookups to succeed. This means in non-interactive contexts a failed lookup
+indicates a bug in the tag inference implementation.
+For this reason we assert that we are running in interactive mode if a lookup fails.
+-}
isTagged :: Id -> RM Bool
isTagged v = do
this_mod <- getMod
+ -- See Note [Tag inference for interactive contexts]
+ let lookupDefault v = assertPpr (isInteractiveModule this_mod)
+ (text "unknown Id:" <> ppr this_mod <+> ppr v)
+ (TagSig TagDunno)
case nameIsLocalOrFrom this_mod (idName v) of
True
| Just Unlifted <- typeLevity_maybe (idType v)
@@ -226,8 +266,8 @@ isTagged v = do
-> return True
| otherwise -> do -- Local binding
!s <- getMap
- let !sig = lookupWithDefaultUFM s (pprPanic "unknown Id:" (ppr v)) v
- return $! case sig of
+ let !sig = lookupWithDefaultUFM s (lookupDefault v) v
+ return $ case sig of
TagSig info ->
case info of
TagDunno -> False
=====================================
compiler/GHC/Stg/InferTags/TagSig.hs
=====================================
@@ -16,6 +16,7 @@ import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Utils.Binary
import GHC.Utils.Panic.Plain
+import Data.Coerce
data TagInfo
= TagDunno -- We don't know anything about the tag.
@@ -64,3 +65,12 @@ isTaggedSig :: TagSig -> Bool
isTaggedSig (TagSig TagProper) = True
isTaggedSig (TagSig TagTagged) = True
isTaggedSig _ = False
+
+seqTagSig :: TagSig -> ()
+seqTagSig = coerce seqTagInfo
+
+seqTagInfo :: TagInfo -> ()
+seqTagInfo TagTagged = ()
+seqTagInfo TagDunno = ()
+seqTagInfo TagProper = ()
+seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis
\ No newline at end of file
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -13,6 +13,7 @@ module GHC.Stg.Pipeline
( StgPipelineOpts (..)
, StgToDo (..)
, stg2stg
+ , StgCgInfos
) where
import GHC.Prelude
@@ -39,6 +40,9 @@ import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import GHC.Settings (Platform)
+import GHC.Stg.InferTags (inferTags)
+import GHC.Types.Name.Env (NameEnv)
+import GHC.Stg.InferTags.TagSig (TagSig)
data StgPipelineOpts = StgPipelineOpts
{ stgPipeline_phases :: ![StgToDo]
@@ -52,6 +56,10 @@ data StgPipelineOpts = StgPipelineOpts
newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
deriving (Functor, Applicative, Monad, MonadIO)
+-- | Information to be exposed in interface files which is produced
+-- by the stg2stg passes.
+type StgCgInfos = NameEnv TagSig
+
instance MonadUnique StgM where
getUniqueSupplyM = StgM $ do { mask <- ask
; liftIO $! mkSplitUniqSupply mask}
@@ -66,7 +74,7 @@ stg2stg :: Logger
-> StgPipelineOpts
-> Module -- ^ module being compiled
-> [StgTopBinding] -- ^ input program
- -> IO [CgStgTopBinding] -- output program
+ -> IO ([CgStgTopBinding], StgCgInfos) -- output program
stg2stg logger extra_vars opts this_mod binds
= do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
; showPass logger "Stg2Stg"
@@ -85,7 +93,8 @@ stg2stg logger extra_vars opts this_mod binds
-- This pass will also augment each closure with non-global free variables
-- annotations (which is used by code generator to compute offsets into closures)
; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'
- ; return binds_sorted_with_fvs
+ -- See Note [Tag inference for interactive contexts]
+ ; inferTags (stgPipeline_pprOpts opts) logger this_mod binds_sorted_with_fvs
}
where
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -1669,10 +1669,21 @@ pushAtom d p (StgVarArg var)
case lookupVarEnv topStrings var of
Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $
fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
- Nothing -> do
- let sz = idSizeCon platform var
- massert (sz == wordSize platform)
- return (unitOL (PUSH_G (getName var)), sz)
+ Nothing
+ -- PUSH_G doesn't tag constructors. So we use PACK here
+ -- if we are dealing with nullary constructor.
+ | Just con <- isDataConWorkId_maybe var
+ -> do
+ massert (sz == wordSize platform)
+ massert (isNullaryRepDataCon con)
+ return (unitOL (PACK con 0), sz)
+ | otherwise
+ -> do
+ let
+ massert (sz == wordSize platform)
+ return (unitOL (PUSH_G (getName var)), sz)
+ where
+ !sz = idSizeCon platform var
pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
=====================================
compiler/GHC/StgToCmm/Types.hs
=====================================
@@ -1,7 +1,7 @@
module GHC.StgToCmm.Types
- ( CgInfos (..)
+ ( CmmCgInfos (..)
, LambdaFormInfo (..)
, ModuleLFInfos
, StandardFormInfo (..)
@@ -13,8 +13,6 @@ import GHC.Prelude
import GHC.Core.DataCon
-import GHC.Stg.InferTags.TagSig
-
import GHC.Runtime.Heap.Layout
import GHC.Types.Basic
@@ -85,7 +83,7 @@ moving parts are:
--
-- See also Note [Conveying CAF-info and LFInfo between modules] above.
--
-data CgInfos = CgInfos
+data CmmCgInfos = CmmCgInfos
{ cgNonCafs :: !NonCaffySet
-- ^ Exported Non-CAFFY closures in the current module. Everything else is
-- either not exported of CAFFY.
@@ -93,7 +91,6 @@ data CgInfos = CgInfos
-- ^ LambdaFormInfos of exported closures in the current module.
, cgIPEStub :: !CStub
-- ^ The C stub which is used for IPE information
- , cgTagSigs :: !(NameEnv TagSig)
}
--------------------------------------------------------------------------------
=====================================
compiler/GHC/Types/Name/Set.hs
=====================================
@@ -220,5 +220,5 @@ findUses dus 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
+newtype NonCaffySet = NonCaffySet { ncs_nameSet :: NameSet }
deriving (Semigroup, Monoid)
=====================================
configure.ac
=====================================
@@ -224,8 +224,9 @@ if test "$WithGhc" = ""
then
AC_MSG_ERROR([GHC is required.])
fi
-FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[8.10],
- [AC_MSG_ERROR([GHC version 8.10 or later is required to compile GHC.])])
+MinBootGhcVersion="9.0"
+FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[$MinBootGhcVersion],
+ [AC_MSG_ERROR([GHC version $MinBootGhcVersion or later is required to compile GHC.])])
if test `expr $GhcMinVersion % 2` = "1"
then
=====================================
docs/users_guide/using.rst
=====================================
@@ -784,7 +784,7 @@ pass to ``--make`` mode.
Then when the compiler starts in ``--make`` mode it will compile both units ``a`` and ``b``.
-There is also very basic support for multple home units in GHCi, at the moment you can start
+There is also very basic support for multiple home units in GHCi, at the moment you can start
a GHCi session with multiple units but only the `:reload`:ghci-cmd: is supported.
.. ghc-flag:: -unit @⟨filename⟩
@@ -809,7 +809,7 @@ units easier.
to this directory. When there are multiple home units the compiler is often
not operating in the standard directory and instead where the cabal.project
file is located. In this case the `-working-dir` option can be passed which specifies
- the path from the current directory to the directory the unit assumes to be it's root,
+ the path from the current directory to the directory the unit assumes to be its root,
normally the directory which contains the cabal file.
When the flag is passed, any relative paths used by the compiler are offset
@@ -868,7 +868,7 @@ multiple home units.
Any external unit must not depend on any home unit.
This closure property is checked by the compiler but it's up to the tool invoking
-GHC to ensure that the supplied list of home units obey this invariant.
+GHC to ensure that the supplied list of home units obeys this invariant.
For example, if we have three units, ``p``, ``q`` and ``r``, where ``p`` depends on ``q`` and
``q`` depends on ``r``, then the closure property states that if we load ``p`` and ``r`` as
@@ -1051,7 +1051,7 @@ See also the ``--help``, ``--version``, ``--numeric-version``, and
:category: verbosity
When GHC can't find an instance for a class, it displays a short
- list of some in the instances it knows about. With this flag it
+ list of some of the instances it knows about. With this flag it
prints *all* the instances it knows about.
.. ghc-flag:: -fhide-source-paths
@@ -1680,9 +1680,9 @@ GHC can also be configured using various environment variables.
.. envvar:: GHC_NO_UNICODE
- When non-empty, disables Unicode diagnostics output will be disabled of locale settings.
+ When non-empty, disables Unicode diagnostics output regardless of locale settings.
.. envvar:: GHC_CHARENC
When set to ``UTF-8`` the compiler will always print UTF-8-encoded output, regardless
- the current locale.
+ of the current locale.
=====================================
libraries/base/GHC/Base.hs
=====================================
@@ -162,10 +162,6 @@ resulting in:
Failed to load interface for ‘GHC.Num.Integer’
There are files missing in the ‘ghc-bignum’ package,
-Note that this is only a problem with the make-based build system. Hadrian
-doesn't interleave compilation of modules from separate packages and respects
-the dependency between `base` and `ghc-bignum`.
-
To ensure that GHC.Num.Integer is there, we must ensure that there is a visible
dependency on GHC.Num.Integer from every module in base. We make GHC.Base
depend on GHC.Num.Integer; and everything else either depends on GHC.Base,
=====================================
testsuite/tests/ghci.debugger/scripts/T12458.stdout
=====================================
@@ -1,2 +1,2 @@
-d = (_t1::forall {k} {a :: k}. D a)
+d = <D>
()
=====================================
testsuite/tests/ghci.debugger/scripts/print018.stdout
=====================================
@@ -1,9 +1,9 @@
Breakpoint 0 activated at Test.hs:40:10-17
Stopped in Test.Test2.poly, Test.hs:40:10-17
_result :: () = _
-x :: a = _
-x = (_t1::a)
-x :: a
+x :: Unary = Unary
+x = Unary
+x :: Unary
()
x = Unary
x :: Unary
=====================================
testsuite/tests/simplStg/should_run/Makefile
=====================================
@@ -1,3 +1,12 @@
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
+
+T22042: T22042_clean
+ "$(TEST_HC)" $(TEST_HC_OPTS) -O T22042a.hs -dynamic -c
+ "$(TEST_HC)" $(TEST_HC_OPTS) -e ":main" T22042.hs T22042a.o
+
+T22042_clean:
+ rm -f T22042a.o T22042a.hi
+
+.PHONY: T22042 T22042_clean
=====================================
testsuite/tests/simplStg/should_run/T22042.hs
=====================================
@@ -0,0 +1,6 @@
+module Main where
+
+import T22042a
+
+main = do
+ putStrLn (foo $ SC A B C)
=====================================
testsuite/tests/simplStg/should_run/T22042.stdout
=====================================
@@ -0,0 +1 @@
+ABC
=====================================
testsuite/tests/simplStg/should_run/T22042a.hs
=====================================
@@ -0,0 +1,10 @@
+module T22042a where
+
+data A = A | AA deriving Show
+data B = B | AB deriving Show
+data C = C | AC deriving Show
+
+data SC = SC !A !B !C
+
+foo :: SC -> String
+foo (SC a b c) = show a ++ show b ++ show c
=====================================
testsuite/tests/simplStg/should_run/all.T
=====================================
@@ -19,3 +19,4 @@ test('T13536a',
[''])
test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a'])
+test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4d092683e1a66559824a2a013e8db278f00a25ca...255437e5ea3f89ff4636d3628e229eb0389a1a0e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4d092683e1a66559824a2a013e8db278f00a25ca...255437e5ea3f89ff4636d3628e229eb0389a1a0e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221017/13749231/attachment-0001.html>
More information about the ghc-commits
mailing list