X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSetLevels.lhs;h=ed420899e8102b6aa6f83daa7419899f895ed3da;hb=23bc35d6bbfefa7def797eb0868cc88e02633914;hp=77db0bc81d43bebe61cec3d83f64200fecd568b6;hpb=520c30d3ee2afd3bb8b7576e49c7f44d7b36663e;p=ghc-hetmet.git diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 77db0bc..ed42089 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -42,36 +42,31 @@ the scrutinee of the case, and we can inline it. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module SetLevels ( setLevels, Level(..), tOP_LEVEL, LevelledBind, LevelledExpr, - incMinorLvl, ltMajLvl, ltLvl, isTopLvl, isInlineCtxt + incMinorLvl, ltMajLvl, ltLvl, isTopLvl ) where #include "HsVersions.h" import CoreSyn -import DynFlags ( FloatOutSwitches(..) ) +import DynFlags ( FloatOutSwitches(..) ) import CoreUtils ( exprType, exprIsTrivial, mkPiTypes ) +import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it -import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst, - cloneIdBndr, cloneRecIdBndrs ) -import Id ( Id, idType, mkSysLocal, isOneShotLambda, - zapDemandIdInfo, - idSpecialisation, idWorkerInfo, setIdInfo +import CoreSubst ( Subst, emptySubst, extendInScope, extendInScopeList, + extendIdSubst, cloneIdBndr, cloneRecIdBndrs ) +import Id ( idType, mkSysLocal, isOneShotLambda, + zapDemandIdInfo, transferPolyIdInfo, + idSpecialisation, idUnfolding, setIdInfo, + setIdStrictness, setIdArity ) -import IdInfo ( workerExists, vanillaIdInfo, isEmptySpecInfo ) +import IdInfo import Var import VarSet import VarEnv @@ -92,9 +87,7 @@ import FastString %************************************************************************ \begin{code} -data Level = InlineCtxt -- A level that's used only for - -- the context parameter ctxt_lvl - | Level Int -- Level number of enclosing lambdas +data Level = Level Int -- Level number of enclosing lambdas Int -- Number of big-lambda and/or case expressions between -- here and the nearest enclosing lambda \end{code} @@ -157,54 +150,37 @@ the worker at all. type LevelledExpr = TaggedExpr Level type LevelledBind = TaggedBind Level +tOP_LEVEL :: Level tOP_LEVEL = Level 0 0 -iNLINE_CTXT = InlineCtxt incMajorLvl :: Level -> Level --- For InlineCtxt we ignore any inc's; we don't want --- to do any floating at all; see notes above -incMajorLvl InlineCtxt = InlineCtxt -incMajorLvl (Level major minor) = Level (major+1) 0 +incMajorLvl (Level major _) = Level (major + 1) 0 incMinorLvl :: Level -> Level -incMinorLvl InlineCtxt = InlineCtxt incMinorLvl (Level major minor) = Level major (minor+1) maxLvl :: Level -> Level -> Level -maxLvl InlineCtxt l2 = l2 -maxLvl l1 InlineCtxt = l1 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 | otherwise = l2 ltLvl :: Level -> Level -> Bool -ltLvl any_lvl InlineCtxt = False -ltLvl InlineCtxt (Level _ _) = True ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft *lambda* level to another -ltMajLvl any_lvl InlineCtxt = False -ltMajLvl InlineCtxt (Level maj2 _) = 0 < maj2 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 isTopLvl :: Level -> Bool isTopLvl (Level 0 0) = True -isTopLvl other = False - -isInlineCtxt :: Level -> Bool -isInlineCtxt InlineCtxt = True -isInlineCtxt other = False +isTopLvl _ = False instance Outputable Level where - ppr InlineCtxt = text "" ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] instance Eq Level where - InlineCtxt == InlineCtxt = True - (Level maj1 min1) == (Level maj2 min2) = maj1==maj2 && min1==min2 - l1 == l2 = False + (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2 \end{code} @@ -221,21 +197,18 @@ setLevels :: FloatOutSwitches -> [LevelledBind] setLevels float_lams binds us - = initLvl us (do_them binds) + = initLvl us (do_them init_env binds) where - -- "do_them"'s main business is to thread the monad along - -- It gives each top binding the same empty envt, because - -- things unbound in the envt have level number zero implicitly - do_them :: [CoreBind] -> LvlM [LevelledBind] - - do_them [] = return [] - do_them (b:bs) = do - (lvld_bind, _) <- lvlTopBind init_env b - lvld_binds <- do_them bs - return (lvld_bind : lvld_binds) - init_env = initialEnv float_lams + do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] + do_them _ [] = return [] + do_them env (b:bs) + = do { (lvld_bind, env') <- lvlTopBind env b + ; lvld_binds <- do_them env' bs + ; return (lvld_bind : lvld_binds) } + +lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) lvlTopBind env (NonRec binder rhs) = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs)) -- Rhs can have no free vars! @@ -273,25 +246,14 @@ 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. \begin{code} -lvlExpr _ _ (_, AnnType ty) = return (Type ty) +lvlExpr _ _ ( _, AnnType ty) = return (Type ty) lvlExpr _ env (_, AnnVar v) = return (lookupVar env v) -lvlExpr _ env (_, AnnLit lit) = return (Lit lit) +lvlExpr _ _ (_, AnnLit lit) = return (Lit lit) lvlExpr ctxt_lvl env (_, AnnApp fun arg) = do - fun' <- lvl_fun fun + fun' <- lvlExpr ctxt_lvl env fun -- We don't do MFE on partial applications arg' <- lvlMFE False ctxt_lvl env arg return (App fun' arg') - where --- gaw 2004 - lvl_fun (_, AnnCase _ _ _ _) = lvlMFE True ctxt_lvl env fun - lvl_fun other = lvlExpr ctxt_lvl env fun - -- We don't do MFE on partial applications generally, - -- but we do if the function is big and hairy, like a case - -lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr) = do --- Don't float anything out of an InlineMe; hence the iNLINE_CTXT - expr' <- lvlExpr iNLINE_CTXT env expr - return (Note InlineMe expr') lvlExpr ctxt_lvl env (_, AnnNote note expr) = do expr' <- lvlExpr ctxt_lvl env expr @@ -308,7 +270,7 @@ lvlExpr ctxt_lvl env (_, AnnCast expr co) = do -- Why not? Because partial applications are fairly rare, and splitting -- lambdas makes them more expensive. -lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs) = do +lvlExpr ctxt_lvl env expr@(_, AnnLam {}) = do new_body <- lvlMFE True new_lvl new_env body return (mkLams new_bndrs new_body) where @@ -363,13 +325,34 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = do @lvlMFE@ is just like @lvlExpr@, except that it might let-bind the expression, so that it can itself be floated. -[NOTE: unlifted MFEs] +Note [Unlifted MFEs] +~~~~~~~~~~~~~~~~~~~~ We don't float unlifted MFEs, which potentially loses big opportunites. For example: \x -> f (h y) where h :: Int -> Int# is expensive. We'd like to float the (h y) outside the \x, but we don't because it's unboxed. Possible solution: box it. +Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f = \x. g (error "urk") +we'd like to float the call to error, to get + lvl = error "urk" + f = \x. g lvl +But, it's very helpful for lvl to get a strictness signature, so that, +for example, its unfolding is not exposed in interface files (unnecessary). +But this float-out might occur after strictness analysis. So we use the +cheap-and-cheerful exprBotStrictness_maybe function. + +Note [Case MFEs] +~~~~~~~~~~~~~~~~ +We don't float a case expression as an MFE from a strict context. Why not? +Because in doing so we share a tiny bit of computation (the switch) but +in exchange we build a thunk, which is bad. This case reduces allocation +by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem. +Doesn't change any other allocation at all. + \begin{code} lvlMFE :: Bool -- True <=> strict context [body of case or let] -> Level -- Level of innermost enclosing lambda/tylam @@ -377,13 +360,27 @@ lvlMFE :: Bool -- True <=> strict context [body of case or let] -> CoreExprWithFVs -- input expression -> LvlM LevelledExpr -- Result expression -lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty) +lvlMFE _ _ _ (_, AnnType ty) = return (Type ty) +-- No point in floating out an expression wrapped in a coercion or note +-- If we do we'll transform lvl = e |> co +-- to lvl' = e; lvl = lvl' |> co +-- and then inline lvl. Better just to float out the payload. +lvlMFE strict_ctxt ctxt_lvl env (_, AnnNote n e) + = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e + ; return (Note n e') } + +lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co) + = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e + ; return (Cast e' co) } + +-- Note [Case MFEs] +lvlMFE True ctxt_lvl env e@(_, AnnCase {}) + = lvlExpr ctxt_lvl env e -- Don't share cases lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) - | isUnLiftedType ty -- Can't let-bind it; see [NOTE: unlifted MFEs] - || isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context + | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs] || exprIsTrivial expr -- Never float if it's trivial || not good_destination = -- Don't float it out @@ -392,8 +389,13 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) | otherwise -- Float it out! = do expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr var <- newLvlVar "lvl" abs_vars ty - return (Let (NonRec (TB var dest_lvl) expr') - (mkVarApps (Var var) abs_vars)) + -- Note [Bottoming floats] + let var_w_str = case exprBotStrictness_maybe expr of + Just (arity,str) -> var `setIdArity` arity + `setIdStrictness` str + Nothing -> var + return (Let (NonRec (TB var_w_str dest_lvl) expr') + (mkVarApps (Var var_w_str) abs_vars)) where expr = deAnnotate ann_expr ty = exprType expr @@ -486,7 +488,8 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone -> LvlM (LevelledBind, LevelEnv) lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) - | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe + | isTyVar bndr -- Don't do anything for TyVar binders + -- (simplifier gets rid of them pronto) = do rhs' <- lvlExpr ctxt_lvl env rhs return (NonRec (TB bndr ctxt_lvl) rhs', env) @@ -511,10 +514,6 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) \begin{code} lvlBind top_lvl ctxt_lvl env (AnnRec pairs) - | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe - = do rhss' <- mapM (lvlExpr ctxt_lvl env) rhss - return (Rec ([TB b ctxt_lvl | b <- bndrs] `zip` rhss'), env) - | null abs_vars = do (new_env, new_bndrs) <- cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss @@ -569,6 +568,8 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs) ---------------------------------------------------- -- Three help functons for the type-abstraction case +lvlFloatRhs :: [CoreBndr] -> Level -> LevelEnv -> CoreExprWithFVs + -> UniqSM (Expr (TaggedBndr Level)) lvlFloatRhs abs_vars dest_lvl env rhs = do rhs' <- lvlExpr rhs_lvl rhs_env rhs return (mkLams abs_vars_w_lvls rhs') @@ -598,7 +599,7 @@ lvlLamBndrs lvl bndrs [] bndrs where go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs) - | isId bndr && -- Go to the next major level if this is a value binder, + | isId bndr && -- Go to the next major level if this is a value binder, not bumped_major && -- and we havn't already gone to the next level (one jump per group) not (isOneShotLambda bndr) -- and it isn't a one-shot lambda = go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs @@ -641,9 +642,9 @@ isFunction :: CoreExprWithFVs -> Bool -- variables. We certainly only want to do it for values, and not for -- constructors. So the simple thing is just to look for lambdas isFunction (_, AnnLam b e) | isId b = True - | otherwise = isFunction e -isFunction (_, AnnNote n e) = isFunction e -isFunction other = False + | otherwise = isFunction e +isFunction (_, AnnNote _ e) = isFunction e +isFunction _ = False \end{code} @@ -684,10 +685,10 @@ initialEnv :: FloatOutSwitches -> LevelEnv initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv) floatLams :: LevelEnv -> Bool -floatLams (FloatOutSw float_lams _, _, _, _) = float_lams +floatLams (fos, _, _, _) = floatOutLambdas fos floatConsts :: LevelEnv -> Bool -floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts +floatConsts (fos, _, _, _) = floatOutConstants fos extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv -- Used when *not* cloning @@ -714,35 +715,45 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs -- incorrectly, because the SubstEnv was still lying around. Ouch! -- KSW 2000-07. +extendInScopeEnv :: LevelEnv -> Var -> LevelEnv +extendInScopeEnv (fl, le, subst, ids) v = (fl, le, extendInScope subst v, ids) + +extendInScopeEnvList :: LevelEnv -> [Var] -> LevelEnv +extendInScopeEnvList (fl, le, subst, ids) vs = (fl, le, extendInScopeList subst vs, ids) + -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can -- (see point 4 of the module overview comment) +extendCaseBndrLvlEnv :: LevelEnv -> Expr (TaggedBndr Level) -> Var -> Level + -> LevelEnv extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl = (float_lams, extendVarEnv lvl_env case_bndr lvl, extendIdSubst subst case_bndr (Var scrut_var), extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var)) -extendCaseBndrLvlEnv env scrut case_bndr lvl +extendCaseBndrLvlEnv env _scrut case_bndr lvl = extendLvlEnv env [TB case_bndr lvl] +extendPolyLvlEnv :: Level -> LevelEnv -> [Var] -> [(Var, Var)] -> LevelEnv extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pairs = (float_lams, foldl add_lvl lvl_env bndr_pairs, foldl add_subst subst bndr_pairs, foldl add_id id_env bndr_pairs) where - add_lvl env (v,v') = extendVarEnv env v' dest_lvl - add_subst env (v,v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) - add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) + add_lvl env (_, v') = extendVarEnv env v' dest_lvl + add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) + add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) +extendCloneLvlEnv :: Level -> LevelEnv -> Subst -> [(Var, Var)] -> LevelEnv extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs = (float_lams, foldl add_lvl lvl_env bndr_pairs, new_subst, foldl add_id id_env bndr_pairs) where - add_lvl env (v,v') = extendVarEnv env v' lvl - add_id env (v,v') = extendVarEnv env v ([v'], Var v') + add_lvl env (_, v') = extendVarEnv env v' lvl + add_id env (v, v') = extendVarEnv env v ([v'], Var v') maxIdLevel :: LevelEnv -> VarSet -> Level @@ -762,7 +773,7 @@ maxIdLevel (_, lvl_env,_,id_env) var_set lookupVar :: LevelEnv -> Id -> LevelledExpr lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of Just (_, expr) -> expr - other -> Var v + _ -> Var v abstractVars :: Level -> LevelEnv -> VarSet -> [Var] -- Find the variables in fvs, free vars of the target expresion, @@ -781,7 +792,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs v1 `le` v2 = case (is_tv v1, is_tv v2) of (True, False) -> True (False, True) -> False - other -> v1 <= v2 -- Same family + _ -> v1 <= v2 -- Same family is_tv v = isTyVar v && not (isCoVar v) @@ -797,7 +808,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) - zap v | isId v = WARN( workerExists (idWorkerInfo v) || + zap v | isId v = WARN( isInlineRule (idUnfolding v) || not (isEmptySpecInfo (idSpecialisation v)), text "absVarsOf: discarding info on" <+> ppr v ) setIdInfo v vanillaIdInfo @@ -828,20 +839,23 @@ absVarsOf id_env v \begin{code} type LvlM result = UniqSM result -initLvl = initUs_ +initLvl :: UniqSupply -> UniqSM a -> a +initLvl = initUs_ \end{code} + \begin{code} +newPolyBndrs :: Level -> LevelEnv -> [Var] -> [Id] -> UniqSM (LevelEnv, [Id]) newPolyBndrs dest_lvl env abs_vars bndrs = do uniqs <- getUniquesM let new_bndrs = zipWith mk_poly_bndr bndrs uniqs return (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs) where - mk_poly_bndr bndr uniq = mkSysLocal (mkFastString str) uniq poly_ty + mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.lhs + mkSysLocal (mkFastString str) uniq poly_ty where str = "poly_" ++ occNameString (getOccName bndr) poly_ty = mkPiTypes abs_vars (idType bndr) - newLvlVar :: String -> [CoreBndr] -> Type -- Abstract wrt these bndrs @@ -854,8 +868,10 @@ newLvlVar str vars body_ty = do -- to the rules inside each Id. Grr. But it matters. cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id) -cloneVar TopLevel env v ctxt_lvl dest_lvl - = return (env, v) -- Don't clone top level things +cloneVar TopLevel env v _ _ + = return (extendInScopeEnv env v, v) -- Don't clone top level things + -- But do extend the in-scope env, to satisfy the in-scope invariant + cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl = ASSERT( isId v ) do us <- getUniqueSupplyM @@ -866,8 +882,8 @@ cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl return (env', v2) cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id]) -cloneRecVars TopLevel env vs ctxt_lvl dest_lvl - = return (env, vs) -- Don't clone top level things +cloneRecVars TopLevel env vs _ _ + = return (extendInScopeEnvList env vs, vs) -- Don't clone top level things cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl = ASSERT( all isId vs ) do us <- getUniqueSupplyM @@ -880,6 +896,7 @@ cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl -- VERY IMPORTANT: we must zap the demand info -- if the thing is going to float out past a lambda, -- or if it's going to top level (where things can't be strict) +zap_demand :: Level -> Level -> Id -> Id zap_demand dest_lvl ctxt_lvl id | ctxt_lvl == dest_lvl, not (isTopLvl dest_lvl) = id -- Stays, and not going to top level