From: simonpj@microsoft.com Date: Wed, 10 Feb 2010 09:47:33 +0000 (+0000) Subject: Stop fruitless ANF-ing X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9a977e72a47a0e0c2a8bbf254f8b85609f0937f9 Stop fruitless ANF-ing The simplifier is taking more iterations than it should, because we were fruitlessly ANF-ing a top-level declaration of form x = Ptr "foo"# to get x = let v = "foo"# in Ptr v and then inlining v again. This patch makes Simplify.makeTrivial top-level aware, so that it doesn't ANF if it's going to be undone. --- diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index a5a581b..eec4521 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -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 leve +-- 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. %************************************************************************ %* * @@ -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) }