[Git][ghc/ghc][wip/T22802] 7 commits: Factorize hptModulesBelow
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Jan 26 22:21:20 UTC 2023
Simon Peyton Jones pushed to branch wip/T22802 at Glasgow Haskell Compiler / GHC
Commits:
1bd32a35 by Sylvain Henry at 2023-01-26T12:34:21-05:00
Factorize hptModulesBelow
Create and use moduleGraphModulesBelow in GHC.Unit.Module.Graph that
doesn't need anything from the driver to be used.
- - - - -
1262d3f8 by Matthew Pickering at 2023-01-26T12:34:56-05:00
Store dehydrated data structures in CgModBreaks
This fixes a tricky leak in GHCi where we were retaining old copies of
HscEnvs when reloading. If not all modules were recompiled then these
hydrated fields in break points would retain a reference to the old
HscEnv which could double memory usage.
Fixes #22530
- - - - -
e27eb80c by Matthew Pickering at 2023-01-26T12:34:56-05:00
Force more in NFData Name instance
Doesn't force the lazy `OccName` field (#19619) which is already known
as a really bad source of leaks.
When we slam the hammer storing Names on disk (in interface files or the
like), all this should be forced as otherwise a `Name` can easily retain
an `Id` and hence the entire world.
Fixes #22833
- - - - -
3d004d5a by Matthew Pickering at 2023-01-26T12:34:56-05:00
Force OccName in tidyTopName
This occname has just been derived from an `Id`, so need to force it
promptly so we can release the Id back to the world.
Another symptom of the bug caused by #19619
- - - - -
f2a0fea0 by Matthew Pickering at 2023-01-26T12:34:56-05:00
Strict fields in ModNodeKey (otherwise retains HomeModInfo)
Towards #22530
- - - - -
5640cb1d by Sylvain Henry at 2023-01-26T12:35:36-05:00
Hadrian: fix doc generation
Was missing dependencies on files generated by templates (e.g.
ghc.cabal)
- - - - -
6d97a910 by Simon Peyton Jones at 2023-01-26T22:21:57+00:00
Take account of loop breakers in specLookupRule
The key change is that in GHC.Core.Opt.Specialise.specLookupRule
we were using realIdUnfolding, which ignores the loop-breaker
flag. When given a loop breaker, rule matching therefore
looped infinitely -- #22802.
In fixing this I refactored a bit.
* Define GHC.Core.InScopeEnv as a data type, and use it.
(Previously it was a pair: hard to grep for.)
* Put several functions returning an IdUnfoldingFun into
GHC.Types.Id, namely
idUnfolding
alwaysActiveUnfoldingFun,
whenActiveUnfoldingFun,
noUnfoldingFun
and use them. (The are all loop-breaker aware.)
- - - - -
22 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Unit/Module/Graph.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- + testsuite/tests/simplCore/should_compile/T22802.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -23,12 +23,10 @@ import GHC.Prelude
import GHC.Data.FastString
import GHC.Data.SizedSeq
-import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
-import GHC.Core.Type
import GHC.Types.SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
@@ -41,10 +39,10 @@ import Data.Array.Base ( UArray(..) )
import Data.ByteString (ByteString)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
-import Data.Maybe (catMaybes)
import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
+import GHC.Iface.Syntax
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -174,18 +172,22 @@ instance NFData BCONPtr where
rnf x = x `seq` ()
-- | Information about a breakpoint that we know at code-generation time
+-- In order to be used, this needs to be hydrated relative to the current HscEnv by
+-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for
+-- preventing space leaks (see #22530)
data CgBreakInfo
= CgBreakInfo
- { cgb_vars :: [Maybe (Id,Word16)]
- , cgb_resty :: Type
+ { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint
+ , cgb_vars :: ![Maybe (IfaceIdBndr, Word16)]
+ , cgb_resty :: !IfaceType
}
-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
--- Not a real NFData instance because we can't rnf Id or Type
seqCgBreakInfo :: CgBreakInfo -> ()
seqCgBreakInfo CgBreakInfo{..} =
- rnf (map snd (catMaybes (cgb_vars))) `seq`
- seqType cgb_resty
+ rnf cgb_tyvars `seq`
+ rnf cgb_vars `seq`
+ rnf cgb_resty
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
=====================================
compiler/GHC/Core.hs
=====================================
@@ -83,7 +83,7 @@ module GHC.Core (
-- * Core rule data types
CoreRule(..),
- RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, RuleOpts,
+ RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts,
-- ** Operations on 'CoreRule's
ruleArity, ruleName, ruleIdName, ruleActivation,
@@ -1171,10 +1171,11 @@ data CoreRule
}
-- See Note [Extra args in the target] in GHC.Core.Rules
+type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
+
-- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are
-- currently in scope. See Note [The InScopeSet invariant].
-type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
-type InScopeEnv = (InScopeSet, IdUnfoldingFun)
+data InScopeEnv = ISE InScopeSet IdUnfoldingFun
type IdUnfoldingFun = Id -> Unfolding
-- A function that embodies how to unfold an Id if you need
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -2402,7 +2402,7 @@ match_cstring_foldr_lit _ _ _ _ _ = Nothing
-- Also, look into variable's unfolding just in case the expression we look for
-- is in a top-level thunk.
stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
-stripStrTopTicks (_,id_unf) e = case e of
+stripStrTopTicks (ISE _ id_unf) e = case e of
Var v
| Just rhs <- expandUnfolding_maybe (id_unf v)
-> stripTicksTop tickishFloatable rhs
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1241,14 +1241,13 @@ getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
-- is 'otherwise' which we want exprIsConApp_maybe to be able to
-- see very early on
getUnfoldingInRuleMatch env
- = (in_scope, id_unf)
+ = ISE in_scope id_unf
where
in_scope = seInScope env
- id_unf id | unf_is_active id = idUnfolding id
- | otherwise = NoUnfolding
- unf_is_active id = isActive (sePhase env) (idInlineActivation id)
- -- When sm_rules was off we used to test for a /stable/ unfolding,
- -- but that seems wrong (#20941)
+ phase = sePhase env
+ id_unf = whenActiveUnfoldingFun (isActive phase)
+ -- When sm_rules was off we used to test for a /stable/ unfolding,
+ -- but that seems wrong (#20941)
----------------------
activeRule :: SimplMode -> Activation -> Bool
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1626,11 +1626,11 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- See Note [Inline specialisations] for why we do not
-- switch off specialisation for inline functions
- = do { -- debugTraceMsg (text "specCalls: some" <+> vcat
- -- [ text "function" <+> ppr fn
- -- , text "calls:" <+> ppr calls_for_me
- -- , text "subst" <+> ppr (se_subst env) ])
- ; foldlM spec_call ([], [], emptyUDs) calls_for_me }
+ = -- pprTrace "specCalls: some" (vcat
+ -- [ text "function" <+> ppr fn
+ -- , text "calls:" <+> ppr calls_for_me
+ -- , text "subst" <+> ppr (se_subst env) ]) $
+ foldlM spec_call ([], [], emptyUDs) calls_for_me
| otherwise -- No calls or RHS doesn't fit our preconceptions
= warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))
@@ -1685,7 +1685,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
, rule_bndrs, rule_lhs_args
, spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
--- ; debugTraceMsg (text "spec_call" <+> vcat
+-- ; pprTrace "spec_call" (vcat
-- [ text "fun: " <+> ppr fn
-- , text "call info: " <+> ppr _ci
-- , text "useful: " <+> ppr useful
@@ -1698,7 +1698,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- , text "rhs_bndrs" <+> ppr rhs_bndrs
-- , text "rhs_body" <+> ppr rhs_body
-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
--- , ppr dx_binds ]
+-- , ppr dx_binds ]) $
+-- return ()
; if not useful -- No useful specialisation
|| already_covered rhs_env2 rules_acc rule_lhs_args
@@ -1795,12 +1796,13 @@ specLookupRule :: SpecEnv -> Id -> [CoreExpr]
-> CompilerPhase -- Look up rules as if we were in this phase
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
specLookupRule env fn args phase rules
- = lookupRule ropts (in_scope, realIdUnfolding) is_active fn args rules
+ = lookupRule ropts in_scope_env is_active fn args rules
where
- dflags = se_dflags env
- in_scope = getSubstInScope (se_subst env)
- ropts = initRuleOpts dflags
- is_active = isActive phase
+ dflags = se_dflags env
+ in_scope = getSubstInScope (se_subst env)
+ in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active)
+ ropts = initRuleOpts dflags
+ is_active = isActive phase
{- Note [Specialising DFuns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -514,7 +514,7 @@ lookupRule :: RuleOpts -> InScopeEnv
-- See Note [Extra args in the target]
-- See comments on matchRule
-lookupRule opts rule_env@(in_scope,_) is_active fn args rules
+lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules
= -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $
case go [] rules of
[] -> Nothing
@@ -574,11 +574,12 @@ isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True
isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })
(Rule { ru_bndrs = bndrs2, ru_args = args2
, ru_name = rule_name2, ru_rhs = rhs2 })
- = isJust (matchN (full_in_scope, id_unfolding_fun)
+ = isJust (matchN in_scope_env
rule_name2 bndrs2 args2 args1 rhs2)
where
- id_unfolding_fun _ = NoUnfolding -- Don't expand in templates
full_in_scope = in_scope `extendInScopeSetList` bndrs1
+ in_scope_env = ISE full_in_scope noUnfoldingFun
+ -- noUnfoldingFun: don't expand in templates
noBlackList :: Activation -> Bool
noBlackList _ = False -- Nothing is black listed
@@ -687,7 +688,7 @@ matchN :: InScopeEnv
-- trailing ones, returning the result of applying the rule to a prefix
-- of the actual arguments.
-matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs
+matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs
= do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es
; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)
(mkEmptySubst in_scope) $
@@ -872,7 +873,7 @@ see `init_menv` in `matchN`.
-}
rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
-rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)
+rvInScopeEnv renv = ISE (rnInScopeSet (rv_lcl renv)) (rv_unf renv)
-- * The domain of the TvSubstEnv and IdSubstEnv are the template
-- variables passed into the match.
@@ -1686,7 +1687,7 @@ ruleAppCheck_help env fn args rules
= text "Rule" <+> doubleQuotes (ftext name)
rule_info opts rule
- | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env)
+ | Just _ <- matchRule opts (ISE emptyInScopeSet (rc_id_unf env))
noBlackList fn args rough_args rule
= text "matches (which is very peculiar!)"
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -242,7 +242,7 @@ simple_opt_expr env expr
rec_ids = soe_rec_ids env
subst = soe_subst env
in_scope = getSubstInScope subst
- in_scope_env = (in_scope, simpleUnfoldingFun)
+ in_scope_env = ISE in_scope alwaysActiveUnfoldingFun
---------------
go (Var v)
@@ -761,11 +761,6 @@ add_info env old_bndr top_level new_rhs new_bndr
False -- may be bottom or not
new_rhs Nothing
-simpleUnfoldingFun :: IdUnfoldingFun
-simpleUnfoldingFun id
- | isAlwaysActive (idInlineActivation id) = idUnfolding id
- | otherwise = noUnfolding
-
wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Nothing body = body
wrapLet (Just (b,r)) body = Let (NonRec b r) body
@@ -1184,7 +1179,7 @@ data ConCont = CC [CoreExpr] Coercion
exprIsConApp_maybe :: HasDebugCallStack
=> InScopeEnv -> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
-exprIsConApp_maybe (in_scope, id_unf) expr
+exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
= go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr)))
where
go :: Either InScopeSet Subst
@@ -1304,7 +1299,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr
| (fun `hasKey` unpackCStringIdKey) ||
(fun `hasKey` unpackCStringUtf8IdKey)
, [arg] <- args
- , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg
+ , Just (LitString str) <- exprIsLiteral_maybe ise arg
= succeedWith in_scope floats $
dealWithStringLiteral fun str co
where
@@ -1400,7 +1395,7 @@ exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
-- Nevertheless we do need to look through unfoldings for
-- string literals, which are vigorously hoisted to top level
-- and not subsequently inlined
-exprIsLiteral_maybe env@(_, id_unf) e
+exprIsLiteral_maybe env@(ISE _ id_unf) e
= case e of
Lit l -> Just l
Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
@@ -1430,14 +1425,14 @@ exprIsLambda_maybe _ (Lam x e)
= Just (x, e, [])
-- Still straightforward: Ticks that we can float out of the way
-exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
+exprIsLambda_maybe ise (Tick t e)
| tickishFloatable t
- , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
+ , Just (x, e, ts) <- exprIsLambda_maybe ise e
= Just (x, e, t:ts)
-- Also possible: A casted lambda. Push the coercion inside
-exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
- | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
+exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co)
+ | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e
-- Only do value lambdas.
-- this implies that x is not in scope in gamma (makes this code simpler)
, not (isTyVar x) && not (isCoVar x)
@@ -1448,7 +1443,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
res
-- Another attempt: See if we find a partial unfolding
-exprIsLambda_maybe (in_scope_set, id_unf) e
+exprIsLambda_maybe ise@(ISE in_scope_set id_unf) e
| (Var f, as, ts) <- collectArgsTicks tickishFloatable e
, idArity f > count isValArg as
-- Make sure there is hope to get a lambda
@@ -1456,7 +1451,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) e
-- Optimize, for beta-reduction
, let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as)
-- Recurse, because of possible casts
- , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
+ , Just (x', e'', ts') <- exprIsLambda_maybe ise e'
, let res = Just (x', e'', ts++ts')
= -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
res
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -43,12 +43,18 @@ module GHC.CoreToIface
, toIfaceVar
-- * Other stuff
, toIfaceLFInfo
+ -- * CgBreakInfo
+ , dehydrateCgBreakInfo
) where
import GHC.Prelude
+import Data.Word
+
import GHC.StgToCmm.Types
+import GHC.ByteCode.Types
+
import GHC.Core
import GHC.Core.TyCon hiding ( pprPromotionQuote )
import GHC.Core.Coercion.Axiom
@@ -685,6 +691,16 @@ toIfaceLFInfo nm lfi = case lfi of
LFLetNoEscape ->
panic "toIfaceLFInfo: LFLetNoEscape"
+-- Dehydrating CgBreakInfo
+
+dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word16)] -> Type -> CgBreakInfo
+dehydrateCgBreakInfo ty_vars idOffSets tick_ty =
+ CgBreakInfo
+ { cgb_tyvars = map toIfaceTvBndr ty_vars
+ , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets
+ , cgb_resty = toIfaceType tick_ty
+ }
+
{- Note [Inlining and hs-boot files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this example (#10083, #12789):
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
module GHC.Driver.Env
( Hsc(..)
@@ -84,10 +83,7 @@ import GHC.Utils.Logger
import Data.IORef
import qualified Data.Set as Set
-import Data.Set (Set)
import GHC.Unit.Module.Graph
-import Data.List (sort)
-import qualified Data.Map as Map
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
@@ -267,35 +263,6 @@ hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd)
(hugElts (hsc_HUG hsc_env))
--- | This function returns all the modules belonging to the home-unit that can
--- be reached by following the given dependencies. Additionally, if both the
--- boot module and the non-boot module can be reached, it only returns the
--- non-boot one.
-hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
-hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below]
- where
- td_map = mgTransDeps (hsc_mod_graph hsc_env)
-
- modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map
-
- filtered_mods = Set.fromDistinctAscList . filter_mods . sort
-
- -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
- -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a
- -- linear sweep with a window of size 2 to remove boot modules for which we
- -- have the corresponding non-boot.
- filter_mods = \case
- (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)
- | m1 == m2 && uid1 == uid2 ->
- let !r' = case b1 of
- NotBoot -> r1
- IsBoot -> r2
- in r' : filter_mods rs
- | otherwise -> r1 : filter_mods (r2:rs)
- rs -> rs
-
-
-
-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
@@ -304,11 +271,12 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
| otherwise
= let hug = hsc_HUG hsc_env
+ mg = hsc_mod_graph hsc_env
in
[ thing
|
-- Find each non-hi-boot module below me
- (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (hptModulesBelow hsc_env uid mn)
+ (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (moduleGraphModulesBelow mg uid mn)
, include_hi_boot || (is_boot == NotBoot)
-- unsavoury: when compiling the base package with --make, we
@@ -324,7 +292,7 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty
msg = vcat [text "missing module" <+> ppr mod,
text "When starting from" <+> ppr mn,
- text "below:" <+> ppr (hptModulesBelow hsc_env uid mn),
+ text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn),
text "Probable cause: out-of-date interface files"]
-- This really shouldn't happen, but see #962
, thing <- things
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -881,7 +881,7 @@ addCoreCt nabla x e = do
where
expr_ty = exprType e
expr_in_scope = mkInScopeSet (exprFreeVars e)
- in_scope_env = (expr_in_scope, const NoUnfolding)
+ in_scope_env = ISE expr_in_scope noUnfoldingFun
-- It's inconvenient to get hold of a global in-scope set
-- here, but it'll only be needed if exprIsConApp_maybe ends
-- up substituting inside a forall or lambda (i.e. seldom)
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -1077,7 +1077,8 @@ tidyTopName mod name_cache maybe_ref occ_env id
-- we have to update the name cache in a nice atomic fashion
| local && internal = do uniq <- takeUniqFromNameCache name_cache
- let new_local_name = mkInternalName uniq occ' loc
+ -- See #19619
+ let new_local_name = occ' `seq` mkInternalName uniq occ' loc
return (occ_env', new_local_name)
-- Even local, internal names must get a unique occurrence, because
-- if we do -split-objs we externalise the name later, in the code generator
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -12,6 +12,7 @@ Type checking of type signatures in interface files
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RecordWildCards #-}
module GHC.IfaceToCore (
tcLookupImported_maybe,
@@ -25,10 +26,15 @@ module GHC.IfaceToCore (
tcIfaceExpr, -- Desired by HERMIT (#7683)
tcIfaceGlobal,
tcIfaceOneShot, tcTopIfaceBindings,
+ hydrateCgBreakInfo
) where
import GHC.Prelude
+import GHC.ByteCode.Types
+
+import Data.Word
+
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Core.Lint ( initLintConfig )
@@ -2166,3 +2172,12 @@ bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)
bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside
= bind_tv tv $ \tv' ->
thing_inside (Bndr tv' vis)
+
+-- CgBreakInfo
+
+hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word16)], Type)
+hydrateCgBreakInfo CgBreakInfo{..} = do
+ bindIfaceTyVars cgb_tyvars $ \_ -> do
+ result_ty <- tcIfaceType cgb_resty
+ mbVars <- mapM (traverse (\(if_gbl, offset) -> (,offset) <$> bindIfaceId if_gbl return)) cgb_vars
+ return (mbVars, result_ty)
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -136,6 +136,7 @@ import GHC.Tc.Solver (simplifyWantedsTcM)
import GHC.Tc.Utils.Monad
import GHC.Core.Class (classTyCon)
import GHC.Unit.Env
+import GHC.IfaceToCore
-- -----------------------------------------------------------------------------
-- running a statement interactively
@@ -562,12 +563,19 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
breaks = getModBreaks hmi
info = expectJust "bindLocalsAtBreakpoint2" $
IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
- mbVars = cgb_vars info
- result_ty = cgb_resty info
occs = modBreaks_vars breaks ! breakInfo_number
span = modBreaks_locs breaks ! breakInfo_number
decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
+ -- Rehydrate to understand the breakpoint info relative to the current environment.
+ -- This design is critical to preventing leaks (#22530)
+ (mbVars, result_ty) <- initIfaceLoad hsc_env
+ $ initIfaceLcl breakInfo_module (text "debugger") NotBoot
+ $ hydrateCgBreakInfo info
+
+
+ let
+
-- Filter out any unboxed ids by changing them to Nothings;
-- we can't bind these at the prompt
mbPointers = nullUnboxed <$> mbVars
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -89,6 +89,7 @@ import Data.Either ( partitionEithers )
import GHC.Stg.Syntax
import qualified Data.IntSet as IntSet
+import GHC.CoreToIface
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -370,10 +371,8 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs)
this_mod <- moduleName <$> getCurrentModule
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
- let breakInfo = CgBreakInfo
- { cgb_vars = idOffSets
- , cgb_resty = tick_ty
- }
+ ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
+ let breakInfo = dehydrateCgBreakInfo ty_vars idOffSets tick_ty
newBreakInfo tick_no breakInfo
hsc_env <- getHscEnv
let cc | Just interp <- hsc_interp hsc_env
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -92,12 +92,14 @@ module GHC.Types.Id (
-- ** Reading 'IdInfo' fields
idArity,
idCallArity, idFunRepArity,
- idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo, idLFInfo_maybe,
idOneShotInfo,
idOccInfo,
+ IdUnfoldingFun, idUnfolding, realIdUnfolding,
+ alwaysActiveUnfoldingFun, whenActiveUnfoldingFun, noUnfoldingFun,
+
-- ** Writing 'IdInfo' fields
setIdUnfolding, zapIdUnfolding, setCaseBndrEvald,
setIdArity,
@@ -126,8 +128,9 @@ module GHC.Types.Id (
import GHC.Prelude
-import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,
- isCompulsoryUnfolding, Unfolding( NoUnfolding ), isEvaldUnfolding, hasSomeUnfolding, noUnfolding )
+import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding
+ , isCompulsoryUnfolding, Unfolding( NoUnfolding )
+ , IdUnfoldingFun, isEvaldUnfolding, hasSomeUnfolding, noUnfolding )
import GHC.Types.Id.Info
import GHC.Types.Basic
@@ -744,9 +747,28 @@ idTagSig_maybe = tagSig . idInfo
-- loop breaker. See 'unfoldingInfo'.
--
-- If you really want the unfolding of a strong loopbreaker, call 'realIdUnfolding'.
-idUnfolding :: Id -> Unfolding
+idUnfolding :: IdUnfoldingFun
idUnfolding id = unfoldingInfo (idInfo id)
+noUnfoldingFun :: IdUnfoldingFun
+noUnfoldingFun _id = noUnfolding
+
+-- | Returns an unfolding only if
+-- (a) not a strong loop breaker and
+-- (b) always active
+alwaysActiveUnfoldingFun :: IdUnfoldingFun
+alwaysActiveUnfoldingFun id
+ | isAlwaysActive (idInlineActivation id) = idUnfolding id
+ | otherwise = noUnfolding
+
+-- | Returns an unfolding only if
+-- (a) not a strong loop breaker and
+-- (b) active in according to is_active
+whenActiveUnfoldingFun :: (Activation -> Bool) -> IdUnfoldingFun
+whenActiveUnfoldingFun is_active id
+ | is_active (idInlineActivation id) = idUnfolding id
+ | otherwise = NoUnfolding
+
realIdUnfolding :: Id -> Unfolding
-- ^ Expose the unfolding if there is one, including for loop breakers
realIdUnfolding id = realUnfoldingInfo (idInfo id)
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -469,7 +469,7 @@ setOccInfo info oc = oc `seq` info { occInfo = oc }
unfoldingInfo :: IdInfo -> Unfolding
unfoldingInfo info
| isStrongLoopBreaker (occInfo info) = trimUnfolding $ realUnfoldingInfo info
- | otherwise = realUnfoldingInfo info
+ | otherwise = realUnfoldingInfo info
setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo info uf
=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -155,7 +155,7 @@ instance Outputable NameSort where
ppr System = text "system"
instance NFData Name where
- rnf Name{..} = rnf n_sort
+ rnf Name{..} = rnf n_sort `seq` rnf n_occ `seq` n_uniq `seq` rnf n_loc
instance NFData NameSort where
rnf (External m) = rnf m
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -22,6 +22,7 @@ module GHC.Unit.Module.Graph
, showModMsg
, moduleGraphNodeModule
, moduleGraphNodeModSum
+ , moduleGraphModulesBelow
, moduleGraphNodes
, SummaryNode
@@ -62,12 +63,14 @@ import System.FilePath
import qualified Data.Map as Map
import GHC.Types.Unique.DSet
import qualified Data.Set as Set
+import Data.Set (Set)
import GHC.Unit.Module
import GHC.Linker.Static.Utils
import Data.Bifunctor
import Data.Either
import Data.Function
+import Data.List (sort)
import GHC.Data.List.SetOps
-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.
@@ -131,8 +134,8 @@ nodeKeyModName :: NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk)
nodeKeyModName _ = Nothing
-data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: ModuleNameWithIsBoot
- , mnkUnitId :: UnitId } deriving (Eq, Ord)
+data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot
+ , mnkUnitId :: !UnitId } deriving (Eq, Ord)
instance Outputable ModNodeKeyWithUid where
ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib
@@ -385,3 +388,30 @@ msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms)
type ModNodeKey = ModuleNameWithIsBoot
+
+-- | This function returns all the modules belonging to the home-unit that can
+-- be reached by following the given dependencies. Additionally, if both the
+-- boot module and the non-boot module can be reached, it only returns the
+-- non-boot one.
+moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
+moduleGraphModulesBelow mg uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below]
+ where
+ td_map = mgTransDeps mg
+
+ modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map
+
+ filtered_mods = Set.fromDistinctAscList . filter_mods . sort
+
+ -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
+ -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a
+ -- linear sweep with a window of size 2 to remove boot modules for which we
+ -- have the corresponding non-boot.
+ filter_mods = \case
+ (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)
+ | m1 == m2 && uid1 == uid2 ->
+ let !r' = case b1 of
+ NotBoot -> r1
+ IsBoot -> r2
+ in r' : filter_mods rs
+ | otherwise -> r1 : filter_mods (r2:rs)
+ rs -> rs
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -12,7 +12,7 @@ import Hadrian.BuildPath
import Hadrian.Haskell.Cabal
import Hadrian.Haskell.Cabal.Type
-import Rules.Generate (ghcPrimDependencies)
+import Rules.Generate (ghcPrimDependencies, generateTemplateResults)
import Base
import Context
import Expression (getContextData, interpretInContext, (?), package)
@@ -68,6 +68,12 @@ pathPath "users_guide" = "docs/users_guide"
pathPath "Haddock" = "utils/haddock/doc"
pathPath _ = ""
+-- Generate files required to build the docs (e.g. ghc.cabal)
+needDocDeps :: Action ()
+needDocDeps = do
+ -- build .cabal files used by the doc engine to list package versions
+ generateTemplateResults
+
-- | Build all documentation
documentationRules :: Rules ()
documentationRules = do
@@ -188,6 +194,9 @@ buildSphinxHtml :: FilePath -> Rules ()
buildSphinxHtml path = do
root <- buildRootRules
root -/- htmlRoot -/- path -/- "index.html" %> \file -> do
+
+ needDocDeps
+
let dest = takeDirectory file
rstFilesDir = pathPath path
rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
@@ -301,6 +310,9 @@ buildSphinxPdf :: FilePath -> Rules ()
buildSphinxPdf path = do
root <- buildRootRules
root -/- pdfRoot -/- path <.> "pdf" %> \file -> do
+
+ needDocDeps
+
withTempDir $ \dir -> do
let rstFilesDir = pathPath path
rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -2,7 +2,7 @@ module Rules.Generate (
isGeneratedCmmFile, compilerDependencies, generatePackageCode,
generateRules, copyRules, generatedDependencies,
ghcPrimDependencies,
- templateRules
+ templateRules, generateTemplateResults
) where
import qualified Data.Set as Set
@@ -243,7 +243,6 @@ templateResults =
, "driver/ghci/ghci-wrapper.cabal"
, "ghc/ghc-bin.cabal"
, "utils/iserv/iserv.cabal"
- , "utils/iserv-proxy/iserv-proxy.cabal"
, "utils/remote-iserv/remote-iserv.cabal"
, "utils/runghc/runghc.cabal"
, "libraries/ghc-boot/ghc-boot.cabal"
@@ -256,6 +255,10 @@ templateResults =
, "libraries/prologue.txt"
]
+-- | Generate all the files we know we have a template for
+generateTemplateResults :: Action ()
+generateTemplateResults = need templateResults
+
templateRules :: Rules ()
templateRules = do
templateResults |%> \out -> do
=====================================
testsuite/tests/simplCore/should_compile/T22802.hs
=====================================
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -O1 #-}
+module T22802 where
+
+class C a where
+ f :: a -> a -> a
+ g :: a -> a -> a
+instance C () where
+ f = g
+ g = f
+
+h :: a -> () -> ()
+h = mapFB f (const ())
+
+mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
+{-# INLINE [0] mapFB #-}
+mapFB c f = \x ys -> c (f x) ys
+
+{-# RULES
+"my-mapFB" forall c a b. mapFB (mapFB c a) b = mapFB c (a.b)
+ #-}
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -470,3 +470,4 @@ test('T22725', normal, compile, ['-O'])
test('T22502', normal, compile, ['-O'])
test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
+test('T22802', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a466d67ccd95b2095e621c65f3924f55f425ef6c...6d97a9100fa615283b2b2a6041fdd17007adc9f0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a466d67ccd95b2095e621c65f3924f55f425ef6c...6d97a9100fa615283b2b2a6041fdd17007adc9f0
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/20230126/e9cc0338/attachment-0001.html>
More information about the ghc-commits
mailing list