diff options
| -rw-r--r-- | compiler/basicTypes/Demand.hs | 7 | ||||
| -rw-r--r-- | compiler/basicTypes/VarEnv.hs | 5 | ||||
| -rw-r--r-- | compiler/stranal/DmdAnal.hs | 188 | ||||
| -rw-r--r-- | compiler/utils/UniqFM.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_run/all.T | 3 |
5 files changed, 128 insertions, 81 deletions
diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs index 8dc7f3b895..2ada6b37b9 100644 --- a/compiler/basicTypes/Demand.hs +++ b/compiler/basicTypes/Demand.hs @@ -36,7 +36,9 @@ module Demand ( appIsBottom, isBottomingSig, pprIfaceStrictSig, trimCPRInfo, returnsCPR_maybe, StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, - isTopSig, hasDemandEnvSig, splitStrictSig, increaseStrictSigArity, + isTopSig, hasDemandEnvSig, + splitStrictSig, strictSigDmdEnv, + increaseStrictSigArity, seqDemand, seqDemandList, seqDmdType, seqStrictSig, @@ -1682,6 +1684,9 @@ isTopSig (StrictSig ty) = isTopDmdType ty hasDemandEnvSig :: StrictSig -> Bool hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) +strictSigDmdEnv :: StrictSig -> DmdEnv +strictSigDmdEnv (StrictSig (DmdType env _ _)) = env + isBottomingSig :: StrictSig -> Bool -- True if the signature diverges or throws an exception isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs index 6e22417de8..146a2fce5f 100644 --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -12,7 +12,8 @@ module VarEnv ( elemVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, alterVarEnv, + plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusVarEnvList, + alterVarEnv, delVarEnvList, delVarEnv, delVarEnv_Directly, minusVarEnv, intersectsVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, @@ -435,6 +436,7 @@ extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a @@ -474,6 +476,7 @@ delVarEnv = delFromUFM minusVarEnv = minusUFM intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) plusVarEnv = plusUFM +plusVarEnvList = plusUFMList lookupVarEnv = lookupUFM filterVarEnv = filterUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs index 44d2d200fb..e2a1dc4493 100644 --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -62,10 +62,10 @@ dmdAnalTopBind :: AnalEnv -> CoreBind -> (AnalEnv, CoreBind) dmdAnalTopBind sigs (NonRec id rhs) - = (extendAnalEnv TopLevel sigs id sig, NonRec id2 rhs2) + = (extendAnalEnv TopLevel sigs id2 (idStrictness id2), NonRec id2 rhs2) where - ( _, _, _, rhs1) = dmdAnalRhsLetDown TopLevel Nothing sigs id rhs - (sig, _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin sigs) id rhs1 + ( _, _, rhs1) = dmdAnalRhsLetDown TopLevel Nothing sigs id rhs + ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin sigs) id rhs1 -- Do two passes to improve CPR information -- See Note [CPR for thunks] -- See Note [Optimistic CPR in the "virgin" case] @@ -284,10 +284,11 @@ dmdAnal' env dmd (Let (NonRec id rhs) body) dmdAnal' env dmd (Let (NonRec id rhs) body) = (body_ty2, Let (NonRec id2 rhs') body') where - (sig, lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env id rhs - (body_ty, body') = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body - (body_ty1, id2) = annotateBndr env body_ty id1 - body_ty2 = addLazyFVs body_ty1 lazy_fv + (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env id rhs + env1 = extendAnalEnv NotTopLevel env id1 (idStrictness id1) + (body_ty, body') = dmdAnal env1 dmd body + (body_ty1, id2) = annotateBndr env body_ty id1 + body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables] -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse @@ -307,7 +308,7 @@ dmdAnal' env dmd (Let (Rec pairs) body) (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs (body_ty, body') = dmdAnal env' dmd body body_ty1 = deleteFVs body_ty (map fst pairs) - body_ty2 = addLazyFVs body_ty1 lazy_fv + body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables] in body_ty2 `seq` (body_ty2, Let (Rec pairs') body') @@ -479,55 +480,53 @@ dmdTransform env var dmd -- Recursive bindings dmdFix :: TopLevelFlag - -> AnalEnv -- Does not include bindings for this binding + -> AnalEnv -- Does not include bindings for this binding -> [(Id,CoreExpr)] - -> (AnalEnv, DmdEnv, - [(Id,CoreExpr)]) -- Binders annotated with stricness info + -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info dmdFix top_lvl env orig_pairs - = (updSigEnv env (sigEnv final_env), lazy_fv, pairs') - -- Return to original virgin state, keeping new signatures + = loop 1 initial_pairs where - bndrs = map fst orig_pairs - initial_env = addInitialSigs top_lvl env bndrs - (final_env, lazy_fv, pairs') = loop 1 initial_env orig_pairs - - loop :: Int - -> AnalEnv -- Already contains the current sigs - -> [(Id,CoreExpr)] - -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - loop n env pairs - = -- pprTrace "dmd loop" (ppr n <+> ppr bndrs $$ ppr env) $ - loop' n env pairs - - loop' n env pairs - | found_fixpoint - = (env', lazy_fv, pairs') - -- Note: return pairs', not pairs. pairs' is the result of - -- processing the RHSs with sigs (= sigs'), whereas pairs - -- is the result of processing the RHSs with the *previous* - -- iteration of sigs. - - | n >= 10 - = -- pprTrace "dmdFix loop" (ppr n <+> (vcat - -- [ text "Sigs:" <+> ppr [ (id,lookupVarEnv (sigEnv env) id, - -- lookupVarEnv (sigEnv env') id) - -- | (id,_) <- pairs], - -- text "env:" <+> ppr env, - -- text "binds:" <+> pprCoreBinding (Rec pairs)])) - (env, lazy_fv, orig_pairs) -- Safe output - -- The lazy_fv part is really important! orig_pairs has no strictness - -- info, including nothing about free vars. But if we have - -- letrec f = ....y..... in ...f... - -- where 'y' is free in f, we must record that y is mentioned, - -- otherwise y will get recorded as absent altogether + bndrs = map fst orig_pairs + + -- See Note [Initialising strictness] + initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ] + + | otherwise = orig_pairs + + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + abort = (env, lazy_fv', zapped_pairs) + where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs) + -- Note [Lazy and unleasheable free variables] + non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs' + lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs + zapped_pairs = zapIdStrictness pairs' + + -- The fixed-point varies the idStrictness field of the binders, and terminates if that + -- annotation does not change any more. + loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + loop n pairs + | found_fixpoint = (final_anal_env, lazy_fv, pairs') + | n == 10 = abort + | otherwise = loop (n+1) pairs' + where + found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs + first_round = n == 1 + (lazy_fv, pairs') = step first_round pairs + final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - | otherwise - = loop (n+1) (nonVirgin env') pairs' + step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) + step first_round pairs = (lazy_fv, pairs') where - found_fixpoint = all (same_sig (sigEnv env) (sigEnv env')) bndrs + -- In all but the first iteration, delete the virgin flag + start_env | first_round = env + | otherwise = nonVirgin env + + start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv) - ((env',lazy_fv), pairs') = mapAccumL my_downRhs (env, emptyDmdEnv) pairs + ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs -- mapAccumL: Use the new signature to do the next pair -- The occurrence analyser has arranged them in a good order -- so this can significantly reduce the number of iterations needed @@ -535,23 +534,39 @@ dmdFix top_lvl env orig_pairs my_downRhs (env, lazy_fv) (id,rhs) = ((env', lazy_fv'), (id', rhs')) where - (sig, lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env id rhs - lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 - env' = extendAnalEnv top_lvl env id sig + (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env id rhs + lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 + env' = extendAnalEnv top_lvl env id (idStrictness id') + + + zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] + zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ] + +{- +Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, for two reasons: + + * To get information on used free variables (both lazy and strict!) + (see Note [Lazy and unleasheable free variables]) + * To ensure that all expressions have been traversed at least once, and any left-over + strictness annotations have been updated. - same_sig sigs sigs' var = lookup sigs var == lookup sigs' var - lookup sigs var = case lookupVarEnv sigs var of - Just (sig,_) -> sig - Nothing -> pprPanic "dmdFix" (ppr var) +This final iteration does not add the variables to the strictness signature +environment, which effectively assigns them 'nopSig' (see "getStrictness") +-} -- Trivial RHS -- See Note [Demand analysis for trivial right-hand sides] dmdAnalTrivialRhs :: AnalEnv -> Id -> CoreExpr -> Var -> - (StrictSig, VarEnv Demand, Id, CoreExpr) + (DmdEnv, Id, CoreExpr) dmdAnalTrivialRhs env id rhs fn - = (fn_str, fn_fv, set_idStrictness env id fn_str, rhs) + = (fn_fv, set_idStrictness env id fn_str, rhs) where fn_str = getStrictness env fn fn_fv | isLocalId fn = unitVarEnv fn topDmd @@ -579,7 +594,7 @@ dmdAnalTrivialRhs env id rhs fn dmdAnalRhsLetDown :: TopLevelFlag -> Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive -> AnalEnv -> Id -> CoreExpr - -> (StrictSig, DmdEnv, Id, CoreExpr) + -> (DmdEnv, Id, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. dmdAnalRhsLetDown top_lvl rec_flag env id rhs @@ -587,7 +602,7 @@ dmdAnalRhsLetDown top_lvl rec_flag env id rhs = dmdAnalTrivialRhs env id rhs fn | otherwise - = (sig_ty, lazy_fv, id', mkLams bndrs' body') + = (lazy_fv, id', mkLams bndrs' body') where (bndrs, body) = collectBinders rhs env_body = foldl extendSigsWithLam env bndrs @@ -604,12 +619,12 @@ dmdAnalRhsLetDown top_lvl rec_flag env id rhs Nothing -> cleanEvalDmd Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc) - -- See Note [Lazy and unleashable free variables] -- See Note [Aggregated demand for cardinality] rhs_fv1 = case rec_flag of Just bs -> reuseEnv (delVarEnvList rhs_fv bs) Nothing -> rhs_fv + -- See Note [Lazy and unleashable free variables] (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1 rhs_res' = trimCPRInfo trim_all trim_sums rhs_res @@ -946,7 +961,7 @@ error stub, but which has RULES, you may want it not to be eliminated in favour of error! Note [Lazy and unleasheable free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We put the strict and once-used FVs in the DmdType of the Id, so that at its call sites we unleash demands on its strict fvs. An example is 'roll' in imaginary/wheel-sieve2 @@ -974,9 +989,32 @@ Incidentally, here's a place where lambda-lifting h would lose the cigar --- we couldn't see the joint strictness in t/x ON THE OTHER HAND + We don't want to put *all* the fv's from the RHS into the -DmdType, because that makes fixpointing very slow --- the -DmdType gets full of lazy demands that are slow to converge. +DmdType. Because + + * it makes the strictness signatures larger, and hence slows down fixpointing + +and + + * it is useless information at the call site anyways: + For lazy, used-many times fv's we will never get any better result than + that, no matter how good the actual demand on the function at the call site + is (unless it is always absent, but then the whole binder is useless). + +Therefore we exclude lazy multiple-used fv's from the environment in the +DmdType. + +But now the signature lies! (Missing variables are assumed to be absent.) To +make up for this, the code that analyses the binding keeps the demand on those +variable separate (usually called "lazy_fv") and adds it to the demand of the +whole binding later. + +What if we decide _not_ to store a strictness signature for a binding at all, as +we do when aborting a fixed-point iteration? The we risk losing the information +that the strict variables are being used. In that case, we take all free variables +mentioned in the (unsound) strictness signature, conservatively approximate the +demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". Note [Lamba-bound unfoldings] @@ -1037,11 +1075,14 @@ emptyAnalEnv dflags fam_envs emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv -sigEnv :: AnalEnv -> SigEnv -sigEnv = ae_sigs +-- | Extend an environment with the strictness IDs attached to the id +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv +extendAnalEnvs top_lvl env vars + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } -updSigEnv :: AnalEnv -> SigEnv -> AnalEnv -updSigEnv env sigs = env { ae_sigs = sigs } +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv +extendSigEnvs top_lvl sigs vars + = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars] extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv extendAnalEnv top_lvl env var sig @@ -1059,15 +1100,6 @@ getStrictness env fn | Just (sig, _) <- lookupSigEnv env fn = sig | otherwise = nopSig -addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv --- See Note [Initialising strictness] -addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids - = env { ae_sigs = extendVarEnvList sigs [ (id, (init_sig id, top_lvl)) - | id <- ids ] } - where - init_sig | virgin = \_ -> botSig - | otherwise = idStrictness - nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs index 244969cc91..be5da8373b 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -49,6 +49,7 @@ module UniqFM ( plusUFM, plusUFM_C, plusUFM_CD, + plusUFMList, minusUFM, intersectUFM, intersectUFM_C, @@ -71,6 +72,8 @@ module UniqFM ( import Unique ( Uniquable(..), Unique, getKey ) import Outputable +import Data.List (foldl') + import qualified Data.IntMap as M import qualified Data.IntSet as S import Data.Typeable @@ -214,6 +217,9 @@ plusUFM_CD f (UFM xm) dx (UFM ym) dy (M.map (\y -> dx `f` y)) xm ym +plusUFMList :: [UniqFM elt] -> UniqFM elt +plusUFMList = foldl' plusUFM emptyUFM + minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 minusUFM (UFM x) (UFM y) = UFM (M.difference x y) diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T index 6846c8281c..d3d4aaff9d 100644 --- a/testsuite/tests/stranal/should_run/all.T +++ b/testsuite/tests/stranal/should_run/all.T @@ -12,4 +12,5 @@ test('T10148', normal, compile_and_run, ['']) test('T10218', normal, compile_and_run, ['']) test('T11076', normal, multimod_compile_and_run, ['T11076.hs', 'T11076_prim.cmm']) test('T11555a', normal, compile_and_run, ['']) -test('T12368', [ exit_code(1), expect_broken(12368) ], compile_and_run, ['']) +test('T12368', exit_code(1), compile_and_run, ['']) +test('T12368a', exit_code(1), compile_and_run, ['']) |