X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=f8462be79fccc3dd4f1ab0ac841dfcc4fb712929;hb=e97df85e14fa5b088fcfee0c2acbd961869e05fe;hp=6a579dbb24e47db7bdf00b910081589bc2db7856;hpb=83361f58746ae08040079a6d809127bca2ae3f4c;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 6a579db..f8462be 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -18,6 +18,7 @@ import Id import MkId ( mkImpossibleExpr, seqId ) import Var import IdInfo +import Name ( mkSystemVarName ) import Coercion import FamInstEnv ( topNormaliseType ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) @@ -337,7 +338,7 @@ 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 body1 + ; (body_env2, body2) <- prepareRhs body_env1 bndr1 body1 ; (env', rhs') <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2) @@ -383,7 +384,7 @@ completeNonRecX :: SimplEnv -> SimplM SimplEnv completeNonRecX env is_strict old_bndr new_bndr new_rhs - = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs + = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_bndr new_rhs ; (env2, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 then do { tick LetFloatFromLet @@ -434,15 +435,19 @@ Here we want to make e1,e2 trivial and get That's what the 'go' loop in prepareRhs does \begin{code} -prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +prepareRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS -prepareRhs env (Cast rhs co) -- Note [Float coercions] +prepareRhs 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') <- makeTrivial env rhs + = do { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs ; return (env', Cast rhs' co) } + where + sanitised_info = vanillaIdInfo `setNewStrictnessInfo` newStrictnessInfo info + `setNewDemandInfo` newDemandInfo info + info = idInfo id -prepareRhs env0 rhs0 +prepareRhs env0 _ rhs0 = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0 ; return (env1, rhs1) } where @@ -492,6 +497,17 @@ and lead to further optimisation. Example: go n = case x of { T m -> go (n-m) } -- This case should optimise +Note [Preserve strictness when floating coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Float coercions] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + Note [Float coercions (unlifted)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BUT don't do [Float coercions] if 'e' has an unlifted type. @@ -512,16 +528,19 @@ These strange casts can happen as a result of case-of-case \begin{code} makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable -makeTrivial env expr +makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr + +makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Propagate strictness and demand info to the new binder +-- Note [Preserve strictness when floating coercions] +makeTrivialWithInfo env info expr | exprIsTrivial expr = return (env, expr) | otherwise -- See Note [Take care] below - = do { var <- newId (fsLit "a") (exprType expr) + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "a") + var = mkLocalIdWithInfo name (exprType expr) info ; env' <- completeNonRecX env False var var expr --- pprTrace "makeTrivial" (vcat [ppr var <+> ppr (exprArity (substExpr env' (Var var))) --- , ppr expr --- , ppr (substExpr env' (Var var)) --- , ppr (idArity (fromJust (lookupInScope (seInScope env') var))) ]) $ ; return (env', substExpr env' (Var var)) } -- The substitution is needed becase we're constructing a new binding -- a = rhs @@ -654,7 +673,7 @@ simplUnfolding env _ _ _ _ (DFunUnfolding con ops) simplUnfolding env top_lvl _ _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_guidance = guide@(InlineRule {}) }) - = do { expr' <- simplExpr (setMode SimplGently env) expr + = do { expr' <- simplExpr (setMode simplGentlyForInlineRules env) expr -- See Note [Simplifying gently inside InlineRules] in SimplUtils ; let mb_wkr' = CoreSubst.substInlineRuleInfo (mkCoreSubst env) (ir_info guide) ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity @@ -1592,31 +1611,6 @@ improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] improveSeq _ env scrut _ case_bndr1 _ = return (env, scrut, case_bndr1) - -{- - improve_case_bndr env scrut case_bndr - -- See Note [no-case-of-case] - -- | switchIsOn (getSwitchChecker env) NoCaseOfCase - -- = (env, case_bndr) - - | otherwise -- Failed try; see Note [Suppressing the case binder-swap] - -- not (isEvaldUnfolding (idUnfolding v)) - = case scrut of - Var v -> (modifyInScope env1 v case_bndr', case_bndr') - -- Note about using modifyInScope for v here - -- We could extend the substitution instead, but it would be - -- a hack because then the substitution wouldn't be idempotent - -- any more (v is an OutId). And this does just as well. - - Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr') - where - rhs = Cast (Var case_bndr') (mkSymCoercion co) - - _ -> (env, case_bndr) - where - case_bndr' = zapIdOccInfo case_bndr - env1 = modifyInScope env case_bndr case_bndr' --} \end{code}