diff options
Diffstat (limited to 'compiler/simplCore')
| -rw-r--r-- | compiler/simplCore/CSE.hs | 16 | ||||
| -rw-r--r-- | compiler/simplCore/CallArity.hs | 8 | ||||
| -rw-r--r-- | compiler/simplCore/CoreMonad.hs | 2 | ||||
| -rw-r--r-- | compiler/simplCore/Exitify.hs | 6 | ||||
| -rw-r--r-- | compiler/simplCore/FloatIn.hs | 10 | ||||
| -rw-r--r-- | compiler/simplCore/FloatOut.hs | 10 | ||||
| -rw-r--r-- | compiler/simplCore/LiberateCase.hs | 4 | ||||
| -rw-r--r-- | compiler/simplCore/OccurAnal.hs | 14 | ||||
| -rw-r--r-- | compiler/simplCore/SAT.hs | 4 | ||||
| -rw-r--r-- | compiler/simplCore/SetLevels.hs | 24 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 18 | ||||
| -rw-r--r-- | compiler/simplCore/SimplEnv.hs | 16 | ||||
| -rw-r--r-- | compiler/simplCore/SimplMonad.hs | 4 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.hs | 44 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.hs | 46 |
15 files changed, 113 insertions, 113 deletions
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs index 9a0945e290..8fe56f0965 100644 --- a/compiler/simplCore/CSE.hs +++ b/compiler/simplCore/CSE.hs @@ -15,22 +15,22 @@ module CSE (cseProgram, cseOneExpr) where import GhcPrelude -import CoreSubst +import GHC.Core.Subst import Var ( Var ) import VarEnv ( elemInScopeSet, mkInScopeSet ) import Id ( Id, idType, isDeadBinder, idHasRules , idInlineActivation, setInlineActivation , zapIdOccInfo, zapIdUsageInfo, idInlinePragma , isJoinId, isJoinId_maybe ) -import CoreUtils ( mkAltExpr, eqExpr +import GHC.Core.Utils ( mkAltExpr, eqExpr , exprIsTickedString , stripTicksE, stripTicksT, mkTicks ) -import CoreFVs ( exprFreeVars ) +import GHC.Core.FVs ( exprFreeVars ) import Type ( tyConAppArgs ) -import CoreSyn +import GHC.Core import Outputable import BasicTypes -import CoreMap +import GHC.Core.Map import Util ( filterOut ) import Data.List ( mapAccumL ) @@ -271,7 +271,7 @@ We must not be naive about join points in CSE: join j = e in if b then jump j else 1 + e The expression (1 + jump j) is not good (see Note [Invariants on join points] in -CoreSyn). This seems to come up quite seldom, but it happens (first seen +GHC.Core). This seems to come up quite seldom, but it happens (first seen compiling ppHtml in Haddock.Backends.Xhtml). We could try and be careful by tracking which join points are still valid at @@ -416,7 +416,7 @@ addBinding :: CSEnv -- Includes InId->OutId cloning -- unless we can instead just substitute [in-id -> rhs] -- -- It's possible for the binder to be a type variable (see --- Note [Type-let] in CoreSyn), in which case we can just substitute. +-- Note [Type-let] in GHC.Core), in which case we can just substitute. addBinding env in_id out_id rhs' | not (isId in_id) = (extendCSSubst env in_id rhs', out_id) | noCSE in_id = (env, out_id) @@ -469,7 +469,7 @@ We would normally turn this into: But this breaks an invariant of Core, namely that the RHS of a top-level binding of type Addr# must be a string literal, not another variable. See Note -[CoreSyn top-level string literals] in CoreSyn. +[Core top-level string literals] in GHC.Core. For this reason, we special case top-level bindings to literal strings and leave the original RHS unmodified. This produces: diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs index 36f80c149c..84d62e4ad9 100644 --- a/compiler/simplCore/CallArity.hs +++ b/compiler/simplCore/CallArity.hs @@ -14,10 +14,10 @@ import VarEnv import GHC.Driver.Session ( DynFlags ) import BasicTypes -import CoreSyn +import GHC.Core import Id -import CoreArity ( typeArity ) -import CoreUtils ( exprIsCheap, exprIsTrivial ) +import GHC.Core.Arity ( typeArity ) +import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) import UnVarGraph import Demand import Util @@ -384,7 +384,7 @@ the case for Core! 1. We need to ensure the invariant callArity e <= typeArity (exprType e) for the same reasons that exprArity needs this invariant (see Note - [exprArity invariant] in CoreArity). + [exprArity invariant] in GHC.Core.Arity). If we are not doing that, a too-high arity annotation will be stored with the id, confusing the simplifier later on. diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 84860d56e5..7da11f9062 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -51,7 +51,7 @@ module CoreMonad ( import GhcPrelude hiding ( read ) -import CoreSyn +import GHC.Core import GHC.Driver.Types import Module import GHC.Driver.Session diff --git a/compiler/simplCore/Exitify.hs b/compiler/simplCore/Exitify.hs index f8266fc154..cbb7469e4f 100644 --- a/compiler/simplCore/Exitify.hs +++ b/compiler/simplCore/Exitify.hs @@ -39,13 +39,13 @@ import GhcPrelude import Var import Id import IdInfo -import CoreSyn -import CoreUtils +import GHC.Core +import GHC.Core.Utils import State import Unique import VarSet import VarEnv -import CoreFVs +import GHC.Core.FVs import FastString import Type import Util( mapSnd ) diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs index 47cbb87912..4a690ccfc4 100644 --- a/compiler/simplCore/FloatIn.hs +++ b/compiler/simplCore/FloatIn.hs @@ -22,11 +22,11 @@ module FloatIn ( floatInwards ) where import GhcPrelude -import CoreSyn -import MkCore hiding ( wrapFloats ) -import GHC.Driver.Types ( ModGuts(..) ) -import CoreUtils -import CoreFVs +import GHC.Core +import GHC.Core.Make hiding ( wrapFloats ) +import GHC.Driver.Types ( ModGuts(..) ) +import GHC.Core.Utils +import GHC.Core.FVs import CoreMonad ( CoreM ) import Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) import Var diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs index 18d48d4f12..b8736085dd 100644 --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -12,10 +12,10 @@ module FloatOut ( floatOutwards ) where import GhcPrelude -import CoreSyn -import CoreUtils -import MkCore -import CoreArity ( etaExpand ) +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.Arity ( etaExpand ) import CoreMonad ( FloatOutSwitches(..) ) import GHC.Driver.Session @@ -111,7 +111,7 @@ Well, maybe. We don't do this at the moment. Note [Join points] ~~~~~~~~~~~~~~~~~~ Every occurrence of a join point must be a tail call (see Note [Invariants on -join points] in CoreSyn), so we must be careful with how far we float them. The +join points] in GHC.Core), so we must be careful with how far we float them. The mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling] in SetLevels. For us, the significance is that a binder might be marked to be dropped at the nearest boundary between tail calls and non-tail calls. For diff --git a/compiler/simplCore/LiberateCase.hs b/compiler/simplCore/LiberateCase.hs index 8bea7dbfdb..1347cf37bf 100644 --- a/compiler/simplCore/LiberateCase.hs +++ b/compiler/simplCore/LiberateCase.hs @@ -12,8 +12,8 @@ module LiberateCase ( liberateCase ) where import GhcPrelude import GHC.Driver.Session -import CoreSyn -import CoreUnfold ( couldBeSmallEnoughToInline ) +import GHC.Core +import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) import TysWiredIn ( unitDataConId ) import Id import VarEnv diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 47460178f1..161d1a9010 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -23,11 +23,11 @@ module OccurAnal ( import GhcPrelude -import CoreSyn -import CoreFVs -import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, stripTicksTopE, mkTicks ) -import CoreArity ( joinRhsArity ) +import GHC.Core.Arity ( joinRhsArity ) import Id import IdInfo import Name( localiseName ) @@ -2762,7 +2762,7 @@ setBinderOcc occ_info bndr -- the decision about another binding 'g' might be invalidated if (say) -- 'f' tail-calls 'g'. -- --- See Note [Invariants on join points] in CoreSyn. +-- See Note [Invariants on join points] in GHC.Core. decideJoinPointHood :: TopLevelFlag -> UsageDetails -> [CoreBndr] -> Bool @@ -2835,7 +2835,7 @@ unfolding captured by the INLINE pragma has arity 1. If we try to convert g to be a join point, its unfolding will still have arity 1 (since it is stable, and we don't meddle with stable unfoldings), and Lint will complain (see Note [Invariants on join points], (2a), in -CoreSyn. #13413. +GHC.Core. #13413. Moreover, since g is going to be inlined anyway, there is no benefit from making it a join point. @@ -2847,7 +2847,7 @@ TcInstDcls) we mark recursive things as INLINE but the recursion unravels; so ignoring INLINE pragmas on recursive things isn't good either. -See Invariant 2a of Note [Invariants on join points] in CoreSyn +See Invariant 2a of Note [Invariants on join points] in GHC.Core ************************************************************************ diff --git a/compiler/simplCore/SAT.hs b/compiler/simplCore/SAT.hs index 23e2b601d3..626c4d06b2 100644 --- a/compiler/simplCore/SAT.hs +++ b/compiler/simplCore/SAT.hs @@ -54,8 +54,8 @@ module SAT ( doStaticArgs ) where import GhcPrelude import Var -import CoreSyn -import CoreUtils +import GHC.Core +import GHC.Core.Utils import Type import Coercion import Id diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 60cc676503..e645005b7d 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -66,18 +66,18 @@ module SetLevels ( import GhcPrelude -import CoreSyn +import GHC.Core import CoreMonad ( FloatOutSwitches(..) ) -import CoreUtils ( exprType, exprIsHNF +import GHC.Core.Utils ( exprType, exprIsHNF , exprOkForSpeculation , exprIsTopLevelBindable , isExprLevPoly , collectMakeStaticArgs ) -import CoreArity ( exprBotStrictness_maybe ) -import CoreFVs -- all of it -import CoreSubst -import MkCore ( sortQuantVars ) +import GHC.Core.Arity ( exprBotStrictness_maybe ) +import GHC.Core.FVs -- all of it +import GHC.Core.Subst +import GHC.Core.Make ( sortQuantVars ) import Id import IdInfo @@ -340,7 +340,7 @@ don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE If there were another lambda in @r@'s rhs, it would get level-2 as well. -} -lvlExpr env (_, AnnType ty) = return (Type (CoreSubst.substTy (le_subst env) ty)) +lvlExpr env (_, AnnType ty) = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) lvlExpr env (_, AnnVar v) = return (lookupVar env v) lvlExpr _ (_, AnnLit lit) = return (Lit lit) @@ -522,7 +522,7 @@ Things to note: - exrpIsHNF catches the key case of an evaluated variable - exprOkForSpeculation is /false/ of an evaluated variable; - See Note [exprOkForSpeculation and evaluated variables] in CoreUtils + See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils So we'd actually miss the key case! - Nothing is gained from the extra generality of exprOkForSpeculation @@ -602,7 +602,7 @@ lvlMFE :: LevelEnv -- Level of in-scope names/tyvars -- the expression, so that it can itself be floated. lvlMFE env _ (_, AnnType ty) - = return (Type (CoreSubst.substTy (le_subst env) ty)) + = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) -- No point in floating out an expression wrapped in a coercion or note -- If we do we'll transform lvl = e |> co @@ -628,7 +628,7 @@ lvlMFE env strict_ctxt ann_expr -- See Note [Free join points] || isExprLevPoly expr -- We can't let-bind levity polymorphic expressions - -- See Note [Levity polymorphism invariants] in CoreSyn + -- See Note [Levity polymorphism invariants] in GHC.Core || notWorthFloating expr abs_vars || not float_me = -- Don't float it out @@ -1331,7 +1331,7 @@ substAndLvlBndrs is_rec env lvl bndrs (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) --- So named only to avoid the name clash with CoreSubst.substBndrs +-- So named only to avoid the name clash with GHC.Core.Subst.substBndrs substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs = ( env { le_subst = subst' , le_env = foldl' add_id id_env (bndrs `zip` bndrs') } @@ -1672,7 +1672,7 @@ newPolyBndrs dest_lvl mkSysLocal (mkFastString str) uniq poly_ty where str = "poly_" ++ occNameString (getOccName bndr) - poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr)) + poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr)) -- If we are floating a join point to top level, it stops being -- a join point. Otherwise it continues to be a join point, diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 1acedf2b44..e34e390a9a 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -13,18 +13,18 @@ module SimplCore ( core2core, simplifyExpr ) where import GhcPrelude import GHC.Driver.Session -import CoreSyn +import GHC.Core import GHC.Driver.Types import CSE ( cseProgram ) -import Rules ( mkRuleBase, unionRuleBase, +import GHC.Core.Rules ( mkRuleBase, unionRuleBase, extendRuleBaseList, ruleCheckProgram, addRuleInfo, getRules ) -import PprCore ( pprCoreBindings, pprCoreExpr ) +import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo -import CoreStats ( coreBindsSize, coreBindsStats, exprSize ) -import CoreUtils ( mkTicks, stripTicksTop ) -import CoreLint ( endPass, lintPassResult, dumpPassResult, +import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) +import GHC.Core.Utils ( mkTicks, stripTicksTop ) +import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult, lintAnnots ) import Simplify ( simplTopBinds, simplExpr, simplRules ) import SimplUtils ( simplEnvForGHCi, activeRule, activeUnfolding ) @@ -52,8 +52,8 @@ import WorkWrap ( wwTopBinds ) import SrcLoc import Util import Module -import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) -import GHC.Runtime.Loader -- ( initializePlugins ) +import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) +import GHC.Runtime.Loader -- ( initializePlugins ) import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import UniqFM @@ -701,7 +701,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) (pprCoreBindings tagged_binds); -- Get any new rules, and extend the rule base - -- See Note [Overall plumbing for rules] in Rules.hs + -- See Note [Overall plumbing for rules] in GHC.Core.Rules -- We need to do this regularly, because simplification can -- poke on IdInfo thunks, which in turn brings in new rules -- behind the scenes. Otherwise there's a danger we'll simply diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs index 020607abe6..9e91d2ea5a 100644 --- a/compiler/simplCore/SimplEnv.hs +++ b/compiler/simplCore/SimplEnv.hs @@ -49,15 +49,15 @@ import GhcPrelude import SimplMonad import CoreMonad ( SimplMode(..) ) -import CoreSyn -import CoreUtils +import GHC.Core +import GHC.Core.Utils import Var import VarEnv import VarSet import OrdList import Id -import MkCore ( mkWildValBinder ) -import GHC.Driver.Session ( DynFlags ) +import GHC.Core.Make ( mkWildValBinder ) +import GHC.Driver.Session ( DynFlags ) import TysWiredIn import qualified Type import Type hiding ( substTy, substTyVar, substTyVarBndr ) @@ -149,7 +149,7 @@ pprSimplEnv env | otherwise = ppr v type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr - -- See Note [Extending the Subst] in CoreSubst + -- See Note [Extending the Subst] in GHC.Core.Subst -- | A substitution result. data SimplSR @@ -290,7 +290,7 @@ way to do that is to start of with a representative Id in the in-scope set There can be *occurrences* of wild-id. For example, -MkCore.mkCoreApp transforms +GHC.Core.Make.mkCoreApp transforms e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } This is ok provided 'wild' isn't free in 'e', and that's the delicate thing. Generally, you want to run the simplifier to get rid of the @@ -498,7 +498,7 @@ unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind)) | not (isStrictId bndr) = FltLifted | exprIsTickedString rhs = FltLifted -- String literals can be floated freely. - -- See Note [CoreSyn top-level string literals] in CoreSyn. + -- See Note [Core top-level string literals] in GHC.Core. | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr ) FltCareful @@ -805,7 +805,7 @@ substNonCoVarIdBndr -- Augment the substitution if the unique changed -- Extend the in-scope set with the new Id -- --- Similar to CoreSubst.substIdBndr, except that +-- Similar to GHC.Core.Subst.substIdBndr, except that -- the type of id_subst differs -- all fragile info is zapped substNonCoVarIdBndr new_res_ty diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs index ed0889d1b1..c1045f7875 100644 --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -28,7 +28,7 @@ import Id ( Id, mkSysLocalOrCoVar ) import IdInfo ( IdDetails(..), vanillaIdInfo, setArityInfo ) import Type ( Type, mkLamTypes ) import FamInstEnv ( FamInstEnv ) -import CoreSyn ( RuleEnv(..) ) +import GHC.Core ( RuleEnv(..) ) import UniqSupply import GHC.Driver.Session import CoreMonad @@ -189,7 +189,7 @@ newJoinId bndrs body_ty ; let name = mkSystemVarName uniq (fsLit "$j") join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes] arity = count isId bndrs - -- arity: See Note [Invariants on join points] invariant 2b, in CoreSyn + -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core join_arity = length bndrs details = JoinId join_arity id_info = vanillaIdInfo `setArityInfo` arity diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 9528a73d90..6f46ded027 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -43,14 +43,14 @@ import GhcPrelude import SimplEnv import CoreMonad ( SimplMode(..), Tick(..) ) import GHC.Driver.Session -import CoreSyn -import qualified CoreSubst -import PprCore +import GHC.Core +import qualified GHC.Core.Subst +import GHC.Core.Ppr import TyCoPpr ( pprParendType ) -import CoreFVs -import CoreUtils -import CoreArity -import CoreUnfold +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Arity +import GHC.Core.Unfold import Name import Id import IdInfo @@ -353,7 +353,7 @@ mkFunRules rs = Just (n_required, rs) mkBoringStop :: OutType -> SimplCont mkBoringStop ty = Stop ty BoringCtxt -mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in CoreUnfold +mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in GHC.Core.Unfold mkRhsStop ty = Stop ty RhsCtxt mkLazyArgStop :: OutType -> CallCtxt -> SimplCont @@ -432,7 +432,7 @@ contArgs cont | lone cont = (True, [], cont) | otherwise = go [] cont where - lone (ApplyToTy {}) = False -- See Note [Lone variables] in CoreUnfold + lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold lone (ApplyToVal {}) = False lone (CastIt {}) = False lone _ = True @@ -632,7 +632,7 @@ interestingCallContext env cont -- Can happen if we have (f Int |> co) y -- If f has an INLINE prag we need to give it some -- motivation to inline. See Note [Cast then apply] - -- in CoreUnfold + -- in GHC.Core.Unfold interesting (StrictArg { sc_cci = cci }) = cci interesting (StrictBind {}) = BoringCtxt @@ -1135,7 +1135,7 @@ preInlineUnconditionally -> InExpr -> StaticEnv -- These two go together -> Maybe SimplEnv -- Returned env has extended substitution -- Precondition: rhs satisfies the let/app invariant --- See Note [CoreSyn let/app invariant] in CoreSyn +-- See Note [Core let/app invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, -- for unlifted, side-effect-ful bindings preInlineUnconditionally env top_lvl bndr rhs rhs_env @@ -1259,7 +1259,7 @@ postInlineUnconditionally -> OutExpr -> Bool -- Precondition: rhs satisfies the let/app invariant --- See Note [CoreSyn let/app invariant] in CoreSyn +-- See Note [Core let/app invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, -- for unlifted, side-effect-ful bindings postInlineUnconditionally env top_lvl bndr occ_info rhs @@ -1517,7 +1517,7 @@ tryEtaExpandRhs mode bndr rhs -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because -- these are used to set the bndr's IdInfo (#15517) - -- Note [Invariants on join points] invariant 2b, in CoreSyn + -- Note [Invariants on join points] invariant 2b, in GHC.Core | otherwise = do { (new_arity, is_bot, new_rhs) <- try_expand @@ -1553,7 +1553,7 @@ Note [Eta-expanding at let bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We now eta expand at let-bindings, which is where the payoff comes. The most significant thing is that we can do a simple arity analysis -(in CoreArity.findRhsArity), which we can't do for free-floating lambdas +(in GHC.Core.Arity.findRhsArity), which we can't do for free-floating lambdas One useful consequence of not eta-expanding lambdas is this example: genMap :: C a => ... @@ -1747,21 +1747,21 @@ abstractFloats dflags top_lvl main_tvs floats body = ASSERT( notNull body_floats ) ASSERT( isNilOL (sfJoinFloats floats) ) do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats - ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) } + ; return (float_binds, GHC.Core.Subst.substExpr (text "abstract_floats1") subst body) } where is_top_lvl = isTopLevel top_lvl main_tv_set = mkVarSet main_tvs body_floats = letFloatBinds (sfLetFloats floats) - empty_subst = CoreSubst.mkEmptySubst (sfInScope floats) + empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) - abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind) + abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind) abstract subst (NonRec id rhs) = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs' - subst' = CoreSubst.extendIdSubst subst id poly_app + subst' = GHC.Core.Subst.extendIdSubst subst id poly_app ; return (subst', NonRec poly_id2 poly_rhs) } where - rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs + rhs' = GHC.Core.Subst.substExpr (text "abstract_floats2") subst rhs -- tvs_here: see Note [Which type variables to abstract over] tvs_here = scopedSort $ @@ -1771,10 +1771,10 @@ abstractFloats dflags top_lvl main_tvs floats body abstract subst (Rec prs) = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids - ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps) + ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps) poly_pairs = [ mk_poly2 poly_id tvs_here rhs' | (poly_id, rhs) <- poly_ids `zip` rhss - , let rhs' = CoreSubst.substExpr (text "abstract_floats") + , let rhs' = GHC.Core.Subst.substExpr (text "abstract_floats") subst' rhs ] ; return (subst', Rec poly_pairs) } where @@ -2207,7 +2207,7 @@ mkCase2 dflags scrut bndr alts_ty alts re_sort :: [CoreAlt] -> [CoreAlt] -- Sort the alternatives to re-establish - -- CoreSyn Note [Case expression invariants] + -- GHC.Core Note [Case expression invariants] re_sort alts = sortBy cmpAlt alts add_default :: [CoreAlt] -> [CoreAlt] diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 0c3e0f788b..ad8557b0a4 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -23,8 +23,8 @@ import FamInstEnv ( FamInstEnv ) import Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 import Id import MkId ( seqId ) -import MkCore ( FloatBind, mkImpossibleExpr, castBottomExpr ) -import qualified MkCore as MkCore +import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import qualified GHC.Core.Make import IdInfo import Name ( mkSystemVarName, isExternalName, getOccFS ) import Coercion hiding ( substCo, substCoVar ) @@ -34,16 +34,16 @@ import DataCon ( DataCon, dataConWorkId, dataConRepStrictness , dataConRepArgTys, isUnboxedTupleCon , StrictnessMark (..) ) import CoreMonad ( Tick(..), SimplMode(..) ) -import CoreSyn +import GHC.Core import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd , mkClosedStrictSig, topDmd, botDiv ) import Cpr ( mkCprSig, botCpr ) -import PprCore ( pprCoreExpr ) -import CoreUnfold -import CoreUtils -import CoreOpt ( pushCoTyArg, pushCoValArg - , joinPointBinding_maybe, joinPointBindings_maybe ) -import Rules ( mkRuleInfo, lookupRule, getRules ) +import GHC.Core.Ppr ( pprCoreExpr ) +import GHC.Core.Unfold +import GHC.Core.Utils +import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg + , joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.Rules ( mkRuleInfo, lookupRule, getRules ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, RecFlag(..), Arity ) import MonadUtils ( mapAccumLM, liftIO ) @@ -386,7 +386,7 @@ completeNonRecX :: TopLevelFlag -> SimplEnv -> OutExpr -- Simplified RHS -> SimplM (SimplFloats, SimplEnv) -- The new binding is in the floats -- Precondition: rhs satisfies the let/app invariant --- See Note [CoreSyn let/app invariant] in CoreSyn +-- See Note [Core let/app invariant] in GHC.Core completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = ASSERT2( not (isJoinId new_bndr), ppr new_bndr ) @@ -634,7 +634,7 @@ We want to turn this into: foo1 = "blob"# foo = Ptr foo1 -See Note [CoreSyn top-level string literals] in CoreSyn. +See Note [Core top-level string literals] in GHC.Core. ************************************************************************ * * @@ -782,7 +782,7 @@ propagate the info that x's RHS is bottom to x's IdInfo as rapidly as possible. We use tryEtaExpandRhs on every binding, and it turns ou that the -arity computation it performs (via CoreArity.findRhsArity) already +arity computation it performs (via GHC.Core.Arity.findRhsArity) already does a simple bottoming-expression analysis. So all we need to do is propagate that info to the binder's IdInfo. @@ -1173,7 +1173,7 @@ simplTick env tickish expr cont splitCont other = (mkBoringStop (contHoleType other), other) getDoneId (DoneId id) = id - getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst + getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst getDoneId other = pprPanic "getDoneId" (ppr other) -- Note [case-of-scc-of-case] @@ -1326,7 +1326,7 @@ simplCast env body co0 cont0 | Just (co1, m_co2) <- pushCoValArg co , let new_ty = coercionRKind co1 , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg - -- See Note [Levity polymorphism invariants] in CoreSyn + -- See Note [Levity polymorphism invariants] in GHC.Core -- test: typecheck/should_run/EtaExpandLevPoly = {-#SCC "addCoerce-pushCoValArg" #-} do { tail' <- addCoerceM m_co2 tail @@ -1457,7 +1457,7 @@ simplNonRecE :: SimplEnv -- which may abort the whole process -- -- Precondition: rhs satisfies the let/app invariant --- Note [CoreSyn let/app invariant] in CoreSyn +-- Note [Core let/app invariant] in GHC.Core -- -- The "body" of the binding comes as a pair of ([InId],InExpr) -- representing a lambda; so we recurse back to simplLam @@ -2314,7 +2314,7 @@ We treat the unlifted and lifted cases separately: we won't build a thunk because the let is strict. See also Note [Case-to-let for strictly-used binders] - NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore. + NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in GHC.Core.Make. We want to turn case (absentError "foo") of r -> ...MkT r... into @@ -2346,7 +2346,7 @@ this transformation. If you want to fix the evaluation order, use 'pseq'. See #8900 for an example where the loss of this transformation bit us in practice. -See also Note [Empty case alternatives] in CoreSyn. +See also Note [Empty case alternatives] in GHC.Core. Historical notes @@ -2377,7 +2377,7 @@ There have been various earlier versions of this patch: case_bndr_evald_next _ = False This patch was part of fixing #7542. See also - Note [Eta reduction of an eval'd function] in CoreUtils.) + Note [Eta reduction of an eval'd function] in GHC.Core.Utils.) Further notes about case elimination @@ -2491,7 +2491,7 @@ rebuildCase env scrut case_bndr alts cont _ -> return -- See Note [FloatBinds from constructor wrappers] ( emptyFloats env, - MkCore.wrapFloats wfloats $ + GHC.Core.Make.wrapFloats wfloats $ wrapFloats (floats1 `addFloats` floats2) expr' )} @@ -2551,8 +2551,8 @@ doCaseToLet :: OutExpr -- Scrutinee -- The situation is case scrut of b { DEFAULT -> body } -- Can we transform thus? let { b = scrut } in body doCaseToLet scrut case_bndr - | isTyCoVar case_bndr -- Respect CoreSyn - = isTyCoArg scrut -- Note [CoreSyn type and coercion invariant] + | isTyCoVar case_bndr -- Respect GHC.Core + = isTyCoArg scrut -- Note [Core type and coercion invariant] | isUnliftedType (idType case_bndr) = exprOkForSpeculation scrut @@ -2936,7 +2936,7 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont _ -> return ( emptyFloats env -- See Note [FloatBinds from constructor wrappers] - , MkCore.wrapFloats dc_floats $ + , GHC.Core.Make.wrapFloats dc_floats $ wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } where zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId @@ -3556,7 +3556,7 @@ simplStableUnfolding env top_lvl mb_cont id unf rhs_ty -- But retain a previous boring_ok of True; e.g. see -- the way it is set in calcUnfoldingGuidanceWithArity in return (mkCoreUnfolding src is_top_lvl expr' guide') - -- See Note [Top-level flag on inline rules] in CoreUnfold + -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold _other -- Happens for INLINABLE things -> mkLetUnfolding dflags top_lvl src id expr' } |