X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=effd245a2119e6128da5b12635794fb61959e490;hp=2001a17dcdabcd648a6b172492f059d911478ab5;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=b8ee6f14ca6e9e49015ee9b404cf8b8191fede05 diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 2001a17..effd245 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -15,7 +15,8 @@ import SimplEnv import SimplUtils import FamInstEnv ( FamInstEnv ) import Id -import MkId ( mkImpossibleExpr, seqId ) +import MkId ( seqId, realWorldPrimId ) +import MkCore ( mkImpossibleExpr ) import Var import IdInfo import Name ( mkSystemVarName, isExternalName ) @@ -36,7 +37,6 @@ import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) -import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM ) import Maybes ( orElse ) @@ -338,12 +338,12 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- Simplify the RHS ; (body_env1, body1) <- simplExprF body_env body mkRhsStop -- ANF-ise a constructor or PAP rhs - ; (body_env2, body2) <- prepareRhs body_env1 bndr1 body1 + ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1 ; (env', rhs') <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2) - then -- No floating, just wrap up! - do { rhs' <- mkLam env tvs' (wrapFloats body_env2 body2) + then -- No floating, revert to body1 + do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1) ; return (env, rhs') } else if null tvs then -- Simple floating @@ -374,17 +374,18 @@ simplNonRecX env bndr new_rhs = return env -- Here b is dead, and we avoid creating | otherwise -- the binding b = (a,b) = do { (env', bndr') <- simplBinder env bndr - ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs } + ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } + -- simplNonRecX is only used for NotTopLevel things -completeNonRecX :: SimplEnv +completeNonRecX :: TopLevelFlag -> SimplEnv -> Bool -> InId -- Old binder -> OutId -- New binder -> OutExpr -- Simplified RHS -> SimplM SimplEnv -completeNonRecX env is_strict old_bndr new_bndr new_rhs - = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_bndr new_rhs +completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs + = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs ; (env2, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 then do { tick LetFloatFromLet @@ -435,19 +436,19 @@ Here we want to make e1,e2 trivial and get That's what the 'go' loop in prepareRhs does \begin{code} -prepareRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) +prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS -prepareRhs env id (Cast rhs co) -- Note [Float coercions] +prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)] - = do { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs + = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs ; return (env', Cast rhs' co) } where sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info `setDemandInfo` demandInfo info info = idInfo id -prepareRhs env0 _ rhs0 +prepareRhs top_lvl env0 _ rhs0 = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0 ; return (env1, rhs1) } where @@ -460,7 +461,7 @@ prepareRhs env0 _ rhs0 go n_val_args env (App fun arg) = do { (is_exp, env', fun') <- go (n_val_args+1) env fun ; case is_exp of - True -> do { (env'', arg') <- makeTrivial env' arg + True -> do { (env'', arg') <- makeTrivial top_lvl env' arg ; return (True, env'', App fun' arg') } False -> return (False, env, App fun arg) } go n_val_args env (Var fun) @@ -527,22 +528,25 @@ These strange casts can happen as a result of case-of-case \begin{code} -makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable -makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr +makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr -makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr) +makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo + -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Propagate strictness and demand info to the new binder -- Note [Preserve strictness when floating coercions] -- Returned SimplEnv has same substitution as incoming one -makeTrivialWithInfo env info expr - | exprIsTrivial expr +makeTrivialWithInfo top_lvl env info expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] = return (env, expr) | otherwise -- See Note [Take care] below = do { uniq <- getUniqueM ; let name = mkSystemVarName uniq (fsLit "a") - var = mkLocalIdWithInfo name (exprType expr) info - ; env' <- completeNonRecX env False var var expr + var = mkLocalIdWithInfo name expr_ty info + ; env' <- completeNonRecX top_lvl env False var var expr ; expr' <- simplVar env' var ; return (env', expr') } -- The simplVar is needed becase we're constructing a new binding @@ -554,8 +558,38 @@ makeTrivialWithInfo env info expr -- is what completeNonRecX will do -- To put it another way, it's as if we'd simplified -- let var = e in var + where + expr_ty = exprType expr + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl _ expr_ty + | isTopLevel top_lvl = not (isUnLiftedType expr_ty) + | otherwise = True \end{code} +Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider tih + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +A case in point is literal strings (a MachStr is not regarded as +trivial): + + foo = Ptr "blob"# + +We don't want to ANF-ise this. %************************************************************************ %* * @@ -671,8 +705,8 @@ simplUnfolding :: SimplEnv-> TopLevelFlag -> OccInfo -> OutExpr -> Unfolding -> SimplM Unfolding -- Note [Setting the new unfolding] -simplUnfolding env _ _ _ _ (DFunUnfolding con ops) - = return (DFunUnfolding con ops') +simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops) + = return (DFunUnfolding ar con ops') where ops' = map (substExpr (text "simplUnfolding") env) ops @@ -843,7 +877,7 @@ simplExprF' env expr@(Lam _ _) cont n_params = length bndrs (bndrs, body) = collectBinders expr zap | n_args >= n_params = \b -> b - | otherwise = \b -> if isTyVar b then b + | otherwise = \b -> if isTyCoVar b then b else zapLamIdInfo b -- NB: we count all the args incl type args -- so we must count all the binders (incl type lambdas) @@ -1047,7 +1081,7 @@ simplNonRecE :: SimplEnv -- First deal with type applications and type lets -- (/\a. e) (Type ty) and (let a = Type ty in e) simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont - = ASSERT( isTyVar bndr ) + = ASSERT( isTyCoVar bndr ) do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } @@ -1061,7 +1095,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont (StrictBind bndr bndrs body env cont) } | otherwise - = ASSERT( not (isTyVar bndr) ) + = ASSERT( not (isTyCoVar bndr) ) do { (env1, bndr1) <- simplNonRecBndr env bndr ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se @@ -1103,7 +1137,7 @@ simplNote env (CoreNote s) e cont simplVar :: SimplEnv -> InVar -> SimplM OutExpr -- Look up an InVar in the environment simplVar env var - | isTyVar var + | isTyCoVar var = return (Type (substTyVar env var)) | otherwise = case substId env var of @@ -1734,7 +1768,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) = go vs the_strs where go [] [] = [] - go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') strs | isTyCoVar v = v : go vs' strs go (v:vs') (str:strs) | isMarkedStrict str = evald_v : go vs' strs | otherwise = zapped_v : go vs' strs @@ -1809,7 +1843,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont bind_args env' [] _ = return env' bind_args env' (b:bs') (Type ty : args) - = ASSERT( isTyVar b ) + = ASSERT( isTyCoVar b ) bind_args (extendTvSubst env' b ty) bs' args bind_args env' (b:bs') (arg : args) @@ -1900,7 +1934,7 @@ mkDupableCont env cont@(StrictBind {}) mkDupableCont env (StrictArg info cci cont) -- See Note [Duplicating StrictArg] = do { (env', dup, nodup) <- mkDupableCont env cont - ; (env'', args') <- mapAccumLM makeTrivial env' (ai_args info) + ; (env'', args') <- mapAccumLM (makeTrivial NotTopLevel) env' (ai_args info) ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } mkDupableCont env (ApplyTo _ arg se cont) @@ -1910,7 +1944,7 @@ mkDupableCont env (ApplyTo _ arg se cont) -- in [...hole...] a do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont ; arg' <- simplExpr (se `setInScope` env') arg - ; (env'', arg'') <- makeTrivial env' arg' + ; (env'', arg'') <- makeTrivial NotTopLevel env' arg' ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont ; return (env'', app_cont, nodup_cont) } @@ -1982,7 +2016,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points] - unf = mkInlineRule needSaturated rhs 0 + unf = mkInlineRule rhs Nothing rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs') @@ -1996,7 +2030,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') | otherwise = bndrs' ++ [case_bndr_w_unf] abstract_over bndr - | isTyVar bndr = True -- Abstract over all type variables just in case + | isTyCoVar bndr = True -- Abstract over all type variables just in case | otherwise = not (isDeadBinder bndr) -- The deadness info on the new Ids is preserved by simplBinders @@ -2048,12 +2082,22 @@ An alternative plan is this: but that is bad if 'c' is *not* later scrutinised. So instead we do both: we pass 'c' and 'c#' , and record in c's inlining -that it's really I# c#, thus +(an InlineRule) that it's really I# c#, thus $j = \c# -> \c[=I# c#] -> ...c.... Absence analysis may later discard 'c'. +NB: take great care when doing strictness analysis; + see Note [Lamba-bound unfoldings] in DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. Note [Duplicated env] ~~~~~~~~~~~~~~~~~~~~~