diff options
Diffstat (limited to 'compiler/simplCore')
| -rw-r--r-- | compiler/simplCore/CSE.hs | 2 | ||||
| -rw-r--r-- | compiler/simplCore/CallArity.hs | 4 | ||||
| -rw-r--r-- | compiler/simplCore/CoreMonad.hs | 15 | ||||
| -rw-r--r-- | compiler/simplCore/Exitify.hs | 4 | ||||
| -rw-r--r-- | compiler/simplCore/OccurAnal.hs | 30 | ||||
| -rw-r--r-- | compiler/simplCore/SetLevels.hs | 2 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.hs | 23 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.hs | 10 |
8 files changed, 48 insertions, 42 deletions
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs index 35862aeabe..2bb69fa6f9 100644 --- a/compiler/simplCore/CSE.hs +++ b/compiler/simplCore/CSE.hs @@ -256,7 +256,7 @@ We do not want to extend the substitution with (y -> x |> co); since y is of unlifted type, this would destroy the let/app invariant if (x |> co) was not ok-for-speculation. -But surely (x |> co) is ok-for-speculation, becasue it's a trivial +But surely (x |> co) is ok-for-speculation, because it's a trivial expression, and x's type is also unlifted, presumably. Well, maybe not if you are using unsafe casts. I actually found a case where we had diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs index bd5b3a3055..75c55c698c 100644 --- a/compiler/simplCore/CallArity.hs +++ b/compiler/simplCore/CallArity.hs @@ -162,7 +162,7 @@ The interesting cases of the analysis: Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} * Let v = rhs in body: In addition to the results from the subexpressions, add all co-calls from - everything that the body calls together with v to everthing that is called + everything that the body calls together with v to everything that is called by v. Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body @@ -318,7 +318,7 @@ Note [Taking boring variables into account] If we decide that the variable bound in `let x = e1 in e2` is not interesting, the analysis of `e2` will not report anything about `x`. To ensure that `callArityBind` does still do the right thing we have to take that into account -everytime we would be lookup up `x` in the analysis result of `e2`. +every time we would be lookup up `x` in the analysis result of `e2`. * Instead of calling lookupCallArityRes, we return (0, True), indicating that this variable might be called many times with no arguments. * Instead of checking `calledWith x`, we assume that everything can be called diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index fde925063b..620f24c680 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -64,10 +64,11 @@ import FastString import qualified ErrUtils as Err import ErrUtils( Severity(..) ) import UniqSupply -import UniqFM ( UniqFM, mapUFM, filterUFM ) import MonadUtils import NameCache +import NameEnv import SrcLoc +import Data.Bifunctor ( bimap ) import Data.List import Data.Ord import Data.Dynamic @@ -733,17 +734,19 @@ getPackageFamInstEnv = do -- annotations. -- -- See Note [Annotations] -getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a]) +getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a]) getAnnotations deserialize guts = do hsc_env <- getHscEnv ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) return (deserializeAnns deserialize ann_env) --- | Get at most one annotation of a given type per Unique. -getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) +-- | Get at most one annotation of a given type per annotatable item. +getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a) getFirstAnnotations deserialize guts - = liftM (mapUFM head . filterUFM (not . null)) - $ getAnnotations deserialize guts + = bimap mod name <$> getAnnotations deserialize guts + where + mod = mapModuleEnv head . filterModuleEnv (const $ not . null) + name = mapNameEnv head . filterNameEnv (not . null) {- Note [Annotations] diff --git a/compiler/simplCore/Exitify.hs b/compiler/simplCore/Exitify.hs index f5a4138566..1183e6cf02 100644 --- a/compiler/simplCore/Exitify.hs +++ b/compiler/simplCore/Exitify.hs @@ -431,7 +431,7 @@ To prevent this, we need to recognize exit join points, and then disable inlining. Exit join points, recognizeable using `isExitJoinId` are join points with an -occurence in a recursive group, and can be recognized (after the occurence +occurrence in a recursive group, and can be recognized (after the occurrence analyzer ran!) using `isExitJoinId`. This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, because the lambdas of a non-recursive join point are not considered for @@ -493,7 +493,7 @@ free variables of the join point. We do not just `filter (`elemVarSet` fvs) captured`, as there might be shadowing, and `captured` may contain multiple variables with the same Unique. I -these cases we want to abstract only over the last occurence, hence the `foldr` +these cases we want to abstract only over the last occurrence, hence the `foldr` (with emphasis on the `r`). This is #15110. -} diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index ecad4a585f..500dc7a912 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -371,7 +371,7 @@ That's why we compute So we must *not* postInlineUnconditionally 'g', even though its RHS turns out to be trivial. (I'm assuming that 'g' is - not choosen as a loop breaker.) Why not? Because then we + not chosen as a loop breaker.) Why not? Because then we drop the binding for 'g', which leaves it out of scope in the RULE! @@ -1534,8 +1534,8 @@ occAnalNonRecRhs env bndr bndrs body certainly_inline -- See Note [Cascading inlines] = case occ of - OneOcc { occ_in_lam = in_lam, occ_one_br = one_br } - -> not in_lam && one_br && active && not_stable + OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch } + -> active && not_stable _ -> False is_join_point = isAlwaysTailCalled occ @@ -1783,14 +1783,14 @@ occAnal env (Case scrut bndr ty alts) occ_anal_scrut (Var v) (alt1 : other_alts) | not (null other_alts) || not (isDefaultAlt alt1) - = (mkOneOcc env v True 0, Var v) + = (mkOneOcc env v IsInteresting 0, Var v) -- The 'True' says that the variable occurs in an interesting -- context; the case has at least one non-default alternative occ_anal_scrut (Tick t e) alts | t `tickishScopesLike` SoftScope -- No reason to not look through all ticks here, but only -- for soft-scoped ticks we can do so without having to - -- update returned occurance info (see occAnal) + -- update returned occurrence info (see occAnal) = second (Tick t) $ occ_anal_scrut e alts occ_anal_scrut scrut _alts @@ -1861,7 +1861,7 @@ occAnalApp env (Var fun, args, ticks) n_val_args = valArgCount args n_args = length args - fun_uds = mkOneOcc env fun (n_val_args > 0) n_args + fun_uds = mkOneOcc env fun (if n_val_args > 0 then IsInteresting else NotInteresting) n_args is_exp = isExpandableApp fun n_val_args -- See Note [CONLIKE pragma] in BasicTypes -- The definition of is_exp should match that in Simplify.prepareRhs @@ -2210,7 +2210,7 @@ extendFvs env s Note [Binder swap] ~~~~~~~~~~~~~~~~~~ -The "binder swap" tranformation swaps occurence of the +The "binder swap" tranformation swaps occurrence of the scrutinee of a case for occurrences of the case-binder: (1) case x of b { pi -> ri } @@ -2325,7 +2325,7 @@ as Dead, so we must zap the OccInfo on cb before making the binding x = cb. See #5028. NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier -doesn't use it. So this is only to satisfy the perhpas-over-picky Lint. +doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. Historical note [no-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2475,8 +2475,8 @@ andUDsList = foldl' andUDs emptyDetails mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails mkOneOcc env id int_cxt arity | isLocalId id - = singleton $ OneOcc { occ_in_lam = False - , occ_one_br = True + = singleton $ OneOcc { occ_in_lam = NotInsideLam + , occ_one_br = InOneBranch , occ_int_cxt = int_cxt , occ_tail = AlwaysTailCalled arity } | id `elemVarSet` occ_gbl_scrut env @@ -2535,7 +2535,7 @@ zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo lookupDetails :: UsageDetails -> Id -> OccInfo lookupDetails ud id - | isCoVar id -- We do not currenly gather occurrence info (from types) + | isCoVar id -- We do not currently gather occurrence info (from types) = noOccInfo -- for CoVars, so we must conservatively mark them as used -- See Note [DoO not mark CoVars as dead] | otherwise @@ -2855,7 +2855,7 @@ markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo markMany IAmDead = IAmDead markMany occ = ManyOccs { occ_tail = occ_tail occ } -markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = True } +markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam } markInsideLam occ = occ markNonTailCalled IAmDead = IAmDead @@ -2876,9 +2876,9 @@ orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1 , occ_tail = tail1 }) (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2 , occ_tail = tail2 }) - = OneOcc { occ_one_br = False -- False, because it occurs in both branches - , occ_in_lam = in_lam1 || in_lam2 - , occ_int_cxt = int_cxt1 && int_cxt2 + = OneOcc { occ_one_br = MultipleBranches -- because it occurs in both branches + , occ_in_lam = in_lam1 `mappend` in_lam2 + , occ_int_cxt = int_cxt1 `mappend` int_cxt2 , occ_tail = tail1 `andTailCallInfo` tail2 } orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index da1e31ea6f..223bbcfa97 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -777,7 +777,7 @@ Exammples: It's controlled by a flag (floatConsts), because doing this too early loses opportunities for RULES which (needless to say) are important in some nofib programs (gcd is an example). [SPJ note: -I think this is obselete; the flag seems always on.] +I think this is obsolete; the flag seems always on.] Note [Floating join point bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 5073bbff99..6074d00aa9 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -558,7 +558,7 @@ discarding the arguments to zip. Usually this is fine, but on the LHS of a rule it's not, because 'as' and 'bs' are now not bound on the LHS. -This is a pretty pathalogical example, so I'm not losing sleep over +This is a pretty pathological example, so I'm not losing sleep over it, but the simplest solution was to check sm_inline; if it is False, which it is on the LHS of a rule (see updModeForRules), then don't make use of the strictness info for the function. @@ -1158,12 +1158,12 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs) one_occ IAmDead = True -- Happens in ((\x.1) v) - one_occ (OneOcc { occ_one_br = True -- One textual occurrence - , occ_in_lam = in_lam - , occ_int_cxt = int_cxt }) - | not in_lam = isNotTopLevel top_lvl || early_phase - | otherwise = int_cxt && canInlineInLam rhs - one_occ _ = False + one_occ OneOcc{ occ_one_br = InOneBranch + , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase + one_occ OneOcc{ occ_one_br = InOneBranch + , occ_in_lam = IsInsideLam + , occ_int_cxt = IsInteresting } = canInlineInLam rhs + one_occ _ = False pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env) mode = getMode env @@ -1297,7 +1297,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs -- PRINCIPLE: when we've already simplified an expression once, -- make sure that we only inline it if it's reasonably small. - && (not in_lam || + && (in_lam == NotInsideLam || -- Outside a lambda, we want to be reasonably aggressive -- about inlining into multiple branches of case -- e.g. let x = <non-value> @@ -1306,7 +1306,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs -- the uses in C1, C2 are not 'interesting' -- An example that gets worse if you add int_cxt here is 'clausify' - (isCheapUnfolding unfolding && int_cxt)) + (isCheapUnfolding unfolding && int_cxt == IsInteresting)) -- isCheap => acceptable work duplication; in_lam may be true -- int_cxt to prevent us inlining inside a lambda without some -- good reason. See the notes on int_cxt in preInlineUnconditionally @@ -2251,7 +2251,10 @@ mkCase3 _dflags scrut bndr alts_ty alts -- InIds, so it's crucial that isExitJoinId is only called on freshly -- occ-analysed code. It's not a generic function you can call anywhere. isExitJoinId :: Var -> Bool -isExitJoinId id = isJoinId id && isOneOcc (idOccInfo id) && occ_in_lam (idOccInfo id) +isExitJoinId id + = isJoinId id + && isOneOcc (idOccInfo id) + && occ_in_lam (idOccInfo id) == IsInsideLam {- Note [Dead binders] diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 569bcfd3dc..2613244696 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -1623,7 +1623,7 @@ wrapJoinCont env cont thing_inside = thing_inside env cont | not (sm_case_case (getMode env)) - -- See Note [Join points wih -fno-case-of-case] + -- See Note [Join points with -fno-case-of-case] = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont @@ -1691,7 +1691,7 @@ We need do make the continuation E duplicable (since we are duplicating it) with mkDuableCont. -Note [Join points wih -fno-case-of-case] +Note [Join points with -fno-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Supose case-of-case is switched off, and we are simplifying @@ -2789,8 +2789,8 @@ addEvals _scrut con vs = go vs the_strs where ppr_with_length list = ppr list <+> parens (text "length =" <+> ppr (length list)) - strdisp MarkedStrict = "MarkedStrict" - strdisp NotMarkedStrict = "NotMarkedStrict" + strdisp MarkedStrict = text "MarkedStrict" + strdisp NotMarkedStrict = text "NotMarkedStrict" zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id zapIdOccInfoAndSetEvald str v = @@ -2965,7 +2965,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)) | otherwise = do { dc_args <- mapM (simplVar env) bs - -- dc_ty_args are aready OutTypes, + -- dc_ty_args are already OutTypes, -- but bs are InBndrs ; let con_app = Var (dataConWorkId dc) `mkTyApps` dc_ty_args |