diff options
Diffstat (limited to 'compiler/simplCore/SetLevels.hs')
| -rw-r--r-- | compiler/simplCore/SetLevels.hs | 133 |
1 files changed, 85 insertions, 48 deletions
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 2b533b73bd..b8212c72f3 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -62,6 +62,8 @@ module SetLevels ( #include "HsVersions.h" +import GhcPrelude + import CoreSyn import CoreMonad ( FloatOutSwitches(..) ) import CoreUtils ( exprType, exprIsHNF @@ -79,12 +81,14 @@ import Id import IdInfo import Var import VarSet +import UniqSet ( nonDetFoldUniqSet ) import VarEnv import Literal ( litIsTrivial ) import Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) -import Type ( Type, mkLamTypes, splitTyConApp_maybe ) +import Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType ) +import TyCoRep ( closeOverKindsDSet ) import BasicTypes ( Arity, RecFlag(..), isRec ) import DataCon ( dataConOrigResTy ) import TysWiredIn @@ -120,7 +124,7 @@ data FloatSpec = FloatMe Level -- Float to just inside the binding -- tagged with this level | StayPut Level -- Stay where it is; binding is - -- tagged with tihs level + -- tagged with this level floatSpecLevel :: FloatSpec -> Level floatSpecLevel (FloatMe l) = l @@ -399,13 +403,13 @@ lvlApp env orig_expr ((_,AnnVar fn), args) , Nothing <- isClassOpId_maybe fn = do { rargs' <- mapM (lvlNonTailMFE env False) rargs ; lapp' <- lvlNonTailMFE env False lapp - ; return (foldl App lapp' rargs') } + ; return (foldl' App lapp' rargs') } | otherwise = do { (_, args') <- mapAccumLM lvl_arg stricts args -- Take account of argument strictness; see -- Note [Floating to the top] - ; return (foldl App (lookupVar env fn) args') } + ; return (foldl' App (lookupVar env fn) args') } where n_val_args = count (isValArg . deAnnotate) args arity = idArity fn @@ -446,7 +450,7 @@ lvlApp env _ (fun, args) -- arguments and the function. do { args' <- mapM (lvlNonTailMFE env False) args ; fun' <- lvlNonTailExpr env fun - ; return (foldl App fun' args') } + ; return (foldl' App fun' args') } ------------------------------------------- lvlCase :: LevelEnv -- Level of in-scope names/tyvars @@ -457,7 +461,8 @@ lvlCase :: LevelEnv -- Level of in-scope names/tyvars -> LvlM LevelledExpr -- Result expression lvlCase env scrut_fvs scrut' case_bndr ty alts | [(con@(DataAlt {}), bs, body)] <- alts - , exprOkForSpeculation scrut' -- See Note [Check the output scrutinee for okForSpec] + , exprOkForSpeculation (deTagExpr scrut') + -- See Note [Check the output scrutinee for okForSpec] , not (isTopLvl dest_lvl) -- Can't have top-level cases , not (floatTopLvlOnly env) -- Can float anywhere = -- See Note [Floating cases] @@ -528,7 +533,7 @@ okForSpeculation we must be careful to test the *result* scrutinee ('x' in this case), not the *input* one 'y'. The latter *is* ok for speculation here, but the former is not -- and indeed we can't float the inner case out, at least not unless x is also evaluated at its -binding site. +binding site. See Trac #5453. That's why we apply exprOkForSpeculation to scrut' and not to scrut. -} @@ -557,7 +562,8 @@ lvlMFE env _ (_, AnnType ty) -- and then inline lvl. Better just to float out the payload. lvlMFE env strict_ctxt (_, AnnTick t e) = do { e' <- lvlMFE env strict_ctxt e - ; return (Tick t e') } + ; let t' = substTickish (le_subst env) t + ; return (Tick t' e') } lvlMFE env strict_ctxt (_, AnnCast e (_, co)) = do { e' <- lvlMFE env strict_ctxt e @@ -625,13 +631,14 @@ lvlMFE env strict_ctxt ann_expr expr = deAnnotate ann_expr expr_ty = exprType expr fvs = freeVarsOf ann_expr + fvs_ty = tyCoVarsOfType expr_ty is_bot = isBottomThunk mb_bot_str is_function = isFunction ann_expr mb_bot_str = exprBotStrictness_maybe expr -- See Note [Bottoming floats] -- esp Bottoming floats (2) expr_ok_for_spec = exprOkForSpeculation expr - dest_lvl = destLevel env fvs is_function is_bot False + dest_lvl = destLevel env fvs fvs_ty is_function is_bot False abs_vars = abstractVars dest_lvl env fvs -- float_is_new_lam: the floated thing will be a new value lambda @@ -1024,7 +1031,7 @@ lvlBind env (AnnNonRec bndr rhs) || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) -- so we will ignore this case for now || not (profitableFloat env dest_lvl) - || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs (idType bndr))) + || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty)) -- We can't float an unlifted binding to top level (except -- literal strings), so we don't float it at all. It's a -- bit brutal, but unlifted bindings aren't expensive either @@ -1053,10 +1060,12 @@ lvlBind env (AnnNonRec bndr rhs) ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } where + bndr_ty = idType bndr + ty_fvs = tyCoVarsOfType bndr_ty rhs_fvs = freeVarsOf rhs bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr abs_vars = abstractVars dest_lvl env bind_fvs - dest_lvl = destLevel env bind_fvs (isFunction rhs) is_bot is_join + dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join deann_rhs = deAnnotate rhs mb_bot_str = exprBotStrictness_maybe deann_rhs @@ -1147,7 +1156,8 @@ lvlBind env (AnnRec pairs) `delDVarSetList` bndrs - dest_lvl = destLevel env bind_fvs is_fun is_bot is_join + ty_fvs = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs + dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join abs_vars = abstractVars dest_lvl env bind_fvs profitableFloat :: LevelEnv -> Level -> Bool @@ -1260,7 +1270,7 @@ substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) -- So named only to avoid the name clash with CoreSubst.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') } + , le_env = foldl' add_id id_env (bndrs `zip` bndrs') } , bndrs') where (subst', bndrs') = case is_rec of @@ -1310,13 +1320,16 @@ stayPut new_lvl bndr = TB bndr (StayPut new_lvl) -- Destination level is the max Id level of the expression -- (We'll abstract the type variables, if any.) -destLevel :: LevelEnv -> DVarSet +destLevel :: LevelEnv + -> DVarSet -- Free vars of the term + -> TyCoVarSet -- Free in the /type/ of the term + -- (a subset of the previous argument) -> Bool -- True <=> is function -> Bool -- True <=> is bottom -> Bool -- True <=> is a join point -> Level -- INVARIANT: if is_join=True then result >= join_ceiling -destLevel env fvs is_function is_bot is_join +destLevel env fvs fvs_ty is_function is_bot is_join | isTopLvl max_fv_id_level -- Float even joins if they get to top level -- See Note [Floating join point bindings] = tOP_LEVEL @@ -1328,21 +1341,48 @@ destLevel env fvs is_function is_bot is_join else max_fv_id_level | is_bot -- Send bottoming bindings to the top - = tOP_LEVEL -- regardless; see Note [Bottoming floats] + = as_far_as_poss -- regardless; see Note [Bottoming floats] -- Esp Bottoming floats (1) | Just n_args <- floatLams env , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case , is_function , countFreeIds fvs <= n_args - = tOP_LEVEL -- Send functions to top level; see - -- the comments with isFunction + = as_far_as_poss -- Send functions to top level; see + -- the comments with isFunction | otherwise = max_fv_id_level where - max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the tyvars - -- will be abstracted - join_ceiling = joinCeilingLevel env + join_ceiling = joinCeilingLevel env + max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the + -- tyvars will be abstracted + + as_far_as_poss = maxFvLevel' isId env fvs_ty + -- See Note [Floating and kind casts] + +{- Note [Floating and kind casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case x of + K (co :: * ~# k) -> let v :: Int |> co + v = e + in blah + +Then, even if we are abstracting over Ids, or if e is bottom, we can't +float v outside the 'co' binding. Reason: if we did we'd get + v' :: forall k. (Int ~# Age) => Int |> co +and now 'co' isn't in scope in that type. The underlying reason is +that 'co' is a value-level thing and we can't abstract over that in a +type (else we'd get a dependent type). So if v's /type/ mentions 'co' +we can't float it out beyond the binding site of 'co'. + +That's why we have this as_far_as_poss stuff. Usually as_far_as_poss +is just tOP_LEVEL; but occasionally a coercion variable (which is an +Id) mentioned in type prevents this. + +Example Trac #14270 comment:15. +-} + isFunction :: CoreExprWithFVs -> Bool -- The idea here is that we want to float *functions* to @@ -1439,7 +1479,7 @@ addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level -addLvls dest_lvl env vs = foldl (addLvl dest_lvl) env vs +addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs floatLams :: LevelEnv -> Maybe Int floatLams le = floatOutLambdas (le_switches le) @@ -1476,14 +1516,20 @@ placeJoinCeiling le@(LE { le_ctxt_lvl = lvl }) lvl' = asJoinCeilLvl (incMinorLvl lvl) maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level -maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set - = foldDVarSet max_in tOP_LEVEL var_set +maxFvLevel max_me env var_set + = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set + +maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level +-- Same but for TyCoVarSet +maxFvLevel' max_me env var_set + = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set + +maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level +maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl + = case lookupVarEnv id_env in_var of + Just (abs_vars, _) -> foldr max_out lvl abs_vars + Nothing -> max_out in_var lvl where - max_in in_var lvl - = foldr max_out lvl (case lookupVarEnv id_env in_var of - Just (abs_vars, _) -> abs_vars - Nothing -> [in_var]) - max_out out_var lvl | max_me out_var = case lookupVarEnv lvl_env out_var of Just lvl' -> maxLvl lvl' lvl @@ -1513,17 +1559,14 @@ abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] -- Uniques are not deterministic. abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs = -- NB: sortQuantVars might not put duplicates next to each other - map zap $ sortQuantVars $ uniq - [out_var | out_fv <- dVarSetElems (substDVarSet subst in_fvs) - , out_var <- dVarSetElems (close out_fv) - , abstract_me out_var ] + map zap $ sortQuantVars $ + filter abstract_me $ + dVarSetElems $ + closeOverKindsDSet $ + substDVarSet subst in_fvs -- NB: it's important to call abstract_me only on the OutIds the -- come from substDVarSet (not on fv, which is an InId) where - uniq :: [Var] -> [Var] - -- Remove duplicates, preserving order - uniq = dVarSetElems . mkDVarSet - abstract_me v = case lookupVarEnv lvl_env v of Just lvl -> dest_lvl `ltLvl` lvl Nothing -> False @@ -1536,12 +1579,6 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs setIdInfo v vanillaIdInfo | otherwise = v - close :: Var -> DVarSet -- Close over variables free in the type - -- Result includes the input variable itself - close v = foldDVarSet (unionDVarSet . close) - (unitDVarSet v) - (fvDVarSet $ varTypeTyCoFVs v) - type LvlM result = UniqSM result initLvl :: UniqSupply -> UniqSM a -> a @@ -1559,8 +1596,8 @@ newPolyBndrs dest_lvl ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs bndr_prs = bndrs `zip` new_bndrs env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs - , le_subst = foldl add_subst subst bndr_prs - , le_env = foldl add_id id_env bndr_prs } + , le_subst = foldl' add_subst subst bndr_prs + , le_env = foldl' add_id id_env bndr_prs } ; return (env', new_bndrs) } where add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) @@ -1603,7 +1640,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) rhs_ty | otherwise - = mkLocalIdOrCoVar (mkSystemVarName uniq (mkFastString "lvl")) rhs_ty + = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) @@ -1614,7 +1651,7 @@ cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env , le_join_ceil = new_lvl , le_lvl_env = addLvls new_lvl lvl_env vs' , le_subst = subst' - , le_env = foldl add_id id_env (vs `zip` vs') } + , le_env = foldl' add_id id_env (vs `zip` vs') } ; return (env', vs') } @@ -1636,7 +1673,7 @@ cloneLetVars is_rec prs = vs `zip` vs2 env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 , le_subst = subst' - , le_env = foldl add_id id_env prs } + , le_env = foldl' add_id id_env prs } ; return (env', vs2) } where |