diff options
Diffstat (limited to 'compiler/GHC/Core')
| -rw-r--r-- | compiler/GHC/Core/Opt/Pipeline.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 77 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Env.hs | 99 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Monad.hs | 24 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 2 |
5 files changed, 140 insertions, 67 deletions
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 18ac910d15..aa8f1c14c5 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -593,7 +593,7 @@ simplifyExpr hsc_env expr ; let sz = exprSize expr - ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $ + ; (expr', counts) <- initSmpl logger dflags Nothing rule_env fi_env sz $ simplExprGently simpl_env expr ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats @@ -733,7 +733,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- Simplify the program ((binds1, rules1), counts1) <- - initSmpl logger dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $ + initSmpl logger dflags (Just this_mod) + (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $ do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 407f84a6c5..1318aa5ac7 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -218,7 +218,8 @@ simplTopBinds env0 binds0 -- It's rather as if the top-level binders were imported. -- See note [Glomming] in "GHC.Core.Opt.OccurAnal". -- See Note [Bangs in the Simplifier] - ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) + ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} + simplTopRecBndrs env0 (bindersOfBinds binds0) ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 ; freeTick SimplifierDone ; return (floats, env2) } @@ -1352,8 +1353,9 @@ simplTick env tickish expr cont no_floating_past_tick = do { let (inc,outc) = splitCont cont ; (floats, expr1) <- simplExprF env expr inc + ; mb_mod <- getSimplModule ; let expr2 = wrapFloats floats expr1 - tickish' = simplTickish env tickish + tickish' = simplTickish mb_mod tickish ; rebuild env (mkTick tickish' expr2) outc } @@ -1377,9 +1379,9 @@ simplTick env tickish expr cont -- } - simplTickish env tickish + simplTickish mb_mod tickish | Breakpoint ext n ids <- tickish - = Breakpoint ext n (map (getDoneId . substId env) ids) + = Breakpoint ext n (map (getDoneId . substId mb_mod env) ids) | otherwise = tickish -- Push type application and coercion inside a tick @@ -1960,45 +1962,48 @@ outside. Surprisingly tricky! ************************************************************************ -} -simplVar :: SimplEnv -> InVar -> SimplM OutExpr +simplLocalVar :: SimplEnv -> InVar -> SimplM OutExpr -- Look up an InVar in the environment -simplVar env var +-- Used only in a case alternative +simplLocalVar env var -- Why $! ? See Note [Bangs in the Simplifier] | isTyVar var = return $! Type $! (substTyVar env var) | isCoVar var = return $! Coercion $! (substCoVar env var) | otherwise - = case substId env var of - ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids - in simplExpr env' e - DoneId var1 -> return (Var var1) - DoneEx e _ -> return e + = case substId Nothing env var of + ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids + in simplExpr env' e + DoneId var1 -> return (Var var1) + DoneEx e _ -> return e simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) simplIdF env var cont - = case substId env var of - ContEx tvs cvs ids e -> - let env' = setSubstEnv env tvs cvs ids - in simplExprF env' e cont - -- Don't trim; haven't already simplified e, - -- so the cont is not embodied in e - - DoneId var1 -> - let cont' = trimJoinCont var (isJoinId_maybe var1) cont - in completeCall env var1 cont' - - DoneEx e mb_join -> - let env' = zapSubstEnv env - cont' = trimJoinCont var mb_join cont - in simplExprF env' e cont' - -- Note [zapSubstEnv] - -- The template is already simplified, so don't re-substitute. - -- This is VITAL. Consider - -- let x = e in - -- let y = \z -> ...x... in - -- \ x -> ...y... - -- We'll clone the inner \x, adding x->x' in the id_subst - -- Then when we inline y, we must *not* replace x by x' in - -- the inlined copy!! + = do { mb_mod <- getSimplModule + ; case substId mb_mod env var of + ContEx tvs cvs ids e -> + let env' = setSubstEnv env tvs cvs ids + in simplExprF env' e cont + -- Don't trim; haven't already simplified e, + -- so the cont is not embodied in e + + DoneId var1 -> + let cont' = trimJoinCont var (isJoinId_maybe var1) cont + in completeCall env var1 cont' + + DoneEx e mb_join -> + let env' = zapSubstEnv env + cont' = trimJoinCont var mb_join cont + in simplExprF env' e cont' + -- Note [zapSubstEnv] + -- The template is already simplified, so don't re-substitute. + -- This is VITAL. Consider + -- let x = e in + -- let y = \z -> ...x... in + -- \ x -> ...y... + -- We'll clone the inner \x, adding x->x' in the id_subst + -- Then when we inline y, we must *not* replace x by x' in + -- the inlined copy!! + } --------------------------------------------------------- -- Dealing with a call site @@ -3316,7 +3321,7 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont | exprIsTrivial scrut = return (emptyFloats env , extendIdSubst env bndr (DoneEx scrut Nothing)) -- See Note [Do not duplicate constructor applications] - | otherwise = do { dc_args <- mapM (simplVar env) bs + | otherwise = do { dc_args <- mapM (simplLocalVar env) bs -- dc_ty_args are already OutTypes, -- but bs are InBndrs ; let con_app = Var (dataConWorkId dc) diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 54a5f171ec..ec0af6cc59 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -20,10 +20,10 @@ module GHC.Core.Opt.Simplify.Env ( getSimplRules, -- * Substitution results - SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, + SimplSR(..), mkContEx, substId, lookupRecBndr, -- * Simplifying 'Id' binders - simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, + simplNonRecBndr, simplNonRecJoinBndr, simplTopRecBndrs, simplRecBndrs, simplRecJoinBndrs, simplBinder, simplBinders, substTy, substTyVar, getTCvSubst, substCo, substCoVar, @@ -64,6 +64,8 @@ import qualified GHC.Core.Type as Type import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) import qualified GHC.Core.Coercion as Coercion import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) +import GHC.Unit.Module ( Module ) +import GHC.Types.Name ( nameModule_maybe ) import GHC.Types.Basic import GHC.Utils.Monad import GHC.Utils.Outputable @@ -687,27 +689,77 @@ So we want to look up the inner X.g_34 in the substitution, where we'll find that it has been substituted by b. (Or conceivably cloned.) -} -substId :: SimplEnv -> InId -> SimplSR +substId :: Maybe Module -> SimplEnv -> InId -> SimplSR -- Returns DoneEx only on a non-Var expression -substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v +substId mb_mod (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] - Nothing -> DoneId (refineFromInScope in_scope v) - Just (DoneId v) -> DoneId (refineFromInScope in_scope v) + Nothing -> DoneId (refineFromInScope mb_mod in_scope v) + Just (DoneId v1) -> DoneId (refineFromInScope mb_mod in_scope v1) Just res -> res -- DoneEx non-var, or ContEx - -- Get the most up-to-date thing from the in-scope set - -- Even though it isn't in the substitution, it may be in - -- the in-scope set with better IdInfo. - -- - -- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify. - -refineFromInScope :: InScopeSet -> Var -> Var -refineFromInScope in_scope v - | isLocalId v = case lookupInScope in_scope v of - Just v' -> v' - Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v) - -- c.f #19074 for a subtle place where this went wrong +refineFromInScope :: Maybe Module -> InScopeSet -> Id -> Id +-- Get the most up-to-date thing from the in-scope set +-- Even though it isn't in the substitution (the Nothing case in +-- substId), it may be in the in-scope set with better IdInfo. +-- +-- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify. +refineFromInScope mb_mod in_scope v + | lookup_in_scope + = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v) + -- c.f #19074 for a subtle place where this went wrong | otherwise = v + where + v_mod = nameModule_maybe (varName v) + lookup_in_scope + | isLocalId v = True + ---- Below here v is a Globald ----- + + -- Implicit Ids don't have bindings until they are added by + -- Prep or Tidy, so the won't be in the in-scope set + | isImplicitId v = False + + -- If we are compiling module M and come across a GlobalId M.foo + -- then we want to look it up in the in-scope set + -- See Note [Simplifying recursive modules] + | Just name_mod <- v_mod + , Just this_mod <- mb_mod + = name_mod == this_mod + + -- All other (imported) GlobalIds won't be in the in-scope set + | otherwise = False + +{- Note [Simplifying recursive modules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + M.hs-boot module M where { foo :: Int -> Int } + A.hs module A where { import {-# SOURCE #-} M + ; bar = foo 3 } + M.hs module M where { import A; foo = id; ...bar... } + +In --make mode we'll make an unfolding for `bar` that refers to a GlobalId `M.foo`, +but one with no useful info beyond the type of `foo`. + +Then when compiling M, we inline `bar` and lo! we have an occurrence of a +GlobalId `M.foo` when the binding site `foo = id` is for a LocalId. +Lint rightly complains (seee #20200). + +Solution: + +* In the (unchanging) SimplTopEnv we keep st_module, + which tracks the module being compiled. + +* The field can be Nothing, which is useful for GHCi, and in other + siuations where we don't need to worry about the boot-file problem. + +* When looking up a GlobalId, in refineFromInScope, if the Module part + of the Name is the same as the module being compiled (kept in + st_module), then it look up in the InScopeSet, just like a LocalId. + +* Wrinkle: data constructor workers aren't injected until the end, so + we won't find them in the in-scope set. +-} lookupRecBndr :: SimplEnv -> InId -> OutId -- Look up an Id which has been put into the envt by simplRecBndrs, @@ -716,7 +768,7 @@ lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v = case lookupVarEnv ids v of Just (DoneId v) -> v Just _ -> pprPanic "lookupRecBndr" (ppr v) - Nothing -> refineFromInScope in_scope v + Nothing -> refineFromInScope Nothing in_scope v {- ************************************************************************ @@ -784,8 +836,15 @@ simplNonRecBndr !env id ; seqId id1 `seq` return (env1, id1) } --------------- +simplTopRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv +-- Top-level recursive let binders +-- No need to clone, and the current substitution is empty +simplTopRecBndrs env@(SimplEnv { seInScope = in_scope }) ids + = assert (all (not . isJoinId) ids) $ + return (env { seInScope = extendInScopeSetList in_scope ids }) + simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv --- Recursive let binders +-- Recursive let binders; used for nested (non-top-level) letrecs simplRecBndrs env@(SimplEnv {}) ids -- See Note [Bangs in the Simplifier] = assert (all (not . isJoinId) ids) $ diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index c730a3e981..03dba32c08 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -9,7 +9,7 @@ module GHC.Core.Opt.Simplify.Monad ( -- The monad SimplM, initSmpl, traceSmpl, - getSimplRules, getFamEnvs, getOptCoercionOpts, + getSimplRules, getFamEnvs, getOptCoercionOpts, getSimplModule, -- Unique supply MonadUnique(..), newId, newJoinId, @@ -37,6 +37,7 @@ import GHC.Driver.Config import GHC.Core.Opt.Monad import GHC.Utils.Outputable import GHC.Data.FastString +import GHC.Unit.Module ( Module ) import GHC.Utils.Monad import GHC.Utils.Logger as Logger import GHC.Utils.Misc ( count ) @@ -81,28 +82,32 @@ data SimplTopEnv , st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run , st_rules :: RuleEnv , st_fams :: (FamInstEnv, FamInstEnv) + , st_module :: Maybe Module -- See Note [Simplifying recursive modules] + -- in GHC.Core.Opt.Simplify.Env , st_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options } -initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) +initSmpl :: Logger -> DynFlags + -> Maybe Module -> RuleEnv -> (FamInstEnv, FamInstEnv) -> Int -- Size of the bindings, used to limit -- the number of ticks we allow -> SimplM a -> IO (a, SimplCount) -initSmpl logger dflags rules fam_envs size m +initSmpl logger dflags mb_mod rules fam_envs size m = do -- No init count; set to 0 let simplCount = zeroSimplCount dflags (result, count) <- unSM m env simplCount return (result, count) where - env = STE { st_flags = dflags - , st_logger = logger - , st_rules = rules - , st_max_ticks = computeMaxTicks dflags size - , st_fams = fam_envs + env = STE { st_flags = dflags + , st_logger = logger + , st_rules = rules + , st_max_ticks = computeMaxTicks dflags size + , st_fams = fam_envs + , st_module = mb_mod , st_co_opt_opts = initOptCoercionOpts dflags } @@ -202,6 +207,9 @@ instance MonadIO SimplM where x <- m return (x, sc) +getSimplModule :: SimplM (Maybe Module) +getSimplModule = SM (\st_env sc -> return (st_module st_env, sc)) + getSimplRules :: SimplM RuleEnv getSimplRules = SM (\st_env sc -> return (st_rules st_env, sc)) diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 5c3114e76b..790364b164 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -816,7 +816,7 @@ interestingArg env e = go env 0 e where -- n is # value args to which the expression is applied go env n (Var v) - = case substId env v of + = case substId Nothing env v of DoneId v' -> go_var n v' DoneEx e _ -> go (zapSubstEnv env) n e ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e |