X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=866b2d4fcaf2a85ed25d35b328ae207df6437711;hb=78260da4deee97a866ba83f8d73a8284b371f405;hp=80fced5bd91c236f8f9df8b04fa31d455e6844c9;hpb=53f99d8465ec50f7c37c65658fa346094bd37ded;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 80fced5..866b2d4 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -13,7 +13,6 @@ import SimplMonad import Type hiding ( substTy, extendTvSubst ) import SimplEnv import SimplUtils -import Literal ( mkStringLit ) import MkId ( rUNTIME_ERROR_ID ) import Id import Var @@ -26,7 +25,7 @@ import NewDemand ( isStrictDmd ) import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) ) import CoreUtils -import Rules ( lookupRule ) +import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict ) import CostCentre ( currentCCS ) import TysPrim ( realWorldStatePrimTy ) @@ -36,7 +35,6 @@ import BasicTypes ( TopLevelFlag(..), isTopLevel, import Maybes ( orElse ) import Data.List ( mapAccumL ) import Outputable -import MonadUtils import FastString \end{code} @@ -256,7 +254,7 @@ simplRecBind env0 top_lvl pairs0 ; env1 <- go (zapFloats env_with_info) triples ; return (env0 `addRecFloats` env1) } -- addFloats adds the floats from env1, - -- *and* updates env0 with the in-scope set from env1 + -- _and_ updates env0 with the in-scope set from env1 where add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr)) -- Add the (substituted) rules to the binder @@ -351,21 +349,10 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se do { tick LetFloatFromLet ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2 ; rhs' <- mkLam tvs' body3 - ; env' <- foldlM add_poly_bind env poly_binds + ; let env' = foldl (addPolyBind top_lvl) env poly_binds ; return (env', rhs') } ; completeBind env' top_lvl bndr bndr1 rhs' } - where - add_poly_bind env (NonRec poly_id rhs) - = completeBind env top_lvl poly_id poly_id rhs - -- completeBind adds the new binding in the - -- proper way (ie complete with unfolding etc), - -- and extends the in-scope set - add_poly_bind env bind@(Rec _) - = return (extendFloats env bind) - -- Hack: letrecs are more awkward, so we extend "by steam" - -- without adding unfoldings etc. At worst this leads to - -- more simplifier iterations \end{code} A specialised variant of simplNonRec used when the RHS is already simplified, @@ -521,7 +508,7 @@ makeTrivial env expr | exprIsTrivial expr = return (env, expr) | otherwise -- See Note [Take care] below - = do { var <- newId FSLIT("a") (exprType expr) + = do { var <- newId (fsLit "a") (exprType expr) ; env' <- completeNonRecX env False var var expr ; return (env', substExpr env' (Var var)) } \end{code} @@ -571,10 +558,57 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding - | otherwise - = let + | otherwise + = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr) + where + unfolding | omit_unfolding = NoUnfolding + | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs + old_info = idInfo old_bndr + occ_info = occInfo old_info + wkr = substWorker env (workerInfo old_info) + omit_unfolding = isNonRuleLoopBreaker occ_info || not (activeInline env old_bndr) + +----------------- +addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv +-- Add a new binding to the environment, complete with its unfolding +-- but *do not* do postInlineUnconditionally, because we have already +-- processed some of the scope of the binding +-- We still want the unfolding though. Consider +-- let +-- x = /\a. let y = ... in Just y +-- in body +-- Then we float the y-binding out (via abstractFloats and addPolyBind) +-- but 'x' may well then be inlined in 'body' in which case we'd like the +-- opportunity to inline 'y' too. + +addPolyBind top_lvl env (NonRec poly_id rhs) + = addNonRecWithUnf env poly_id rhs unfolding NoWorker + where + unfolding | not (activeInline env poly_id) = NoUnfolding + | otherwise = mkUnfolding (isTopLevel top_lvl) rhs + -- addNonRecWithInfo adds the new binding in the + -- proper way (ie complete with unfolding etc), + -- and extends the in-scope set + +addPolyBind _ env bind@(Rec _) = extendFloats env bind + -- Hack: letrecs are more awkward, so we extend "by steam" + -- without adding unfoldings etc. At worst this leads to + -- more simplifier iterations + +----------------- +addNonRecWithUnf :: SimplEnv + -> OutId -> OutExpr -- New binder and RHS + -> Unfolding -> WorkerInfo -- and unfolding + -> SimplEnv +-- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set +addNonRecWithUnf env new_bndr rhs unfolding wkr + = final_id `seq` -- This seq forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + addNonRec env final_id rhs + -- The addNonRec adds it to the in-scope set too + where -- Arity info - new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs + new_bndr_info = idInfo new_bndr `setArityInfo` exprArity rhs -- Unfolding info -- Add the unfolding *only* for non-loop-breakers @@ -598,26 +632,12 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- (for example) be no longer strictly demanded. -- The solution here is a bit ad hoc... info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding - `setWorkerInfo` worker_info + `setWorkerInfo` wkr - final_info | omit_unfolding = new_bndr_info - | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf + final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf | otherwise = info_w_unf - + final_id = new_bndr `setIdInfo` final_info - in - -- These seqs forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - final_id `seq` - -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ - return (addNonRec env final_id new_rhs) - -- The addNonRec adds it to the in-scope set too - where - unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs - worker_info = substWorker env (workerInfo old_info) - omit_unfolding = isNonRuleLoopBreaker occ_info || not (activeInline env old_bndr) - old_info = idInfo old_bndr - occ_info = occInfo old_info \end{code} @@ -864,14 +884,7 @@ simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont simplLam env [] body cont = simplExprF env body cont - -- Type-beta reduction -simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont) - = ASSERT( isTyVar bndr ) - do { tick (BetaReduction bndr) - ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg - ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } - - -- Ordinary beta reduction + -- Beta reduction simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont) = do { tick (BetaReduction bndr) ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont } @@ -904,9 +917,11 @@ simplNonRecE :: SimplEnv -- Why? Because of the binder-occ-info-zapping done before -- the call to simplLam in simplExprF (Lam ...) - -- First deal with type lets: let a = Type ty in b + -- 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 - = do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg + = ASSERT( isTyVar bndr ) + do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont @@ -1018,12 +1033,13 @@ completeCall env var cont -- is recursive, and hence a loop breaker: -- foldr k z (build g) = g k z -- So it's up to the programmer: rules can cause divergence - ; rules <- getRules + ; rule_base <- getSimplRules ; let in_scope = getInScope env + rules = getRules rule_base var maybe_rule = case activeRule dflags env of Nothing -> Nothing -- No rules apply Just act_fn -> lookupRule act_fn in_scope - rules var args + var args rules ; case maybe_rule of { Just (rule, rule_rhs) -> do tick (RuleFired (ru_name rule)) @@ -1247,7 +1263,7 @@ rebuildCase env scrut case_bndr alts cont -- inaccessible. So we simply put an error case here instead. pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $ let res_ty' = contResultType env' (substTy env' (coreAltsType alts)) dup_cont - lit = Lit (mkStringLit "Impossible alternative") + lit = mkStringLit "Impossible alternative" in return (env', mkApps (Var rUNTIME_ERROR_ID) [Type res_ty', lit]) else do @@ -1265,15 +1281,18 @@ inlined. Note [no-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~ -There is a time we *don't* want to do that, namely when --fno-case-of-case is on. This happens in the first simplifier pass, -and enhances full laziness. Here's the bad case: - f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) -If we eliminate the inner case, we trap it inside the I# v -> arm, -which might prevent some full laziness happening. I've seen this -in action in spectral/cichelli/Prog.hs: - [(m,n) | m <- [1..max], n <- [1..max]] -Hence the check for NoCaseOfCase. +We *used* to suppress the binder-swap in case expressoins when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. Note [Suppressing the case binder-swap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1485,7 +1504,7 @@ simplCaseBinder env0 scrut0 case_bndr0 alts improve_seq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId FSLIT("nt") ty2 + = do { case_bndr2 <- newId (fsLit "nt") ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) env2 = extendIdSubst env case_bndr rhs ; return (env2, scrut `Cast` co, case_bndr2) } @@ -1495,9 +1514,9 @@ simplCaseBinder env0 scrut0 case_bndr0 alts improve_case_bndr env scrut case_bndr - | switchIsOn (getSwitchChecker env) NoCaseOfCase - -- See Note [no-case-of-case] - = (env, 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)) @@ -1808,11 +1827,13 @@ mkDupableCont env (ApplyTo _ arg se cont) ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env') dup_cont ; return (env'', app_cont, nodup_cont) } -mkDupableCont env cont@(Select _ _ [(_, bs, _rhs)] _ _) +mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _) -- See Note [Single-alternative case] -- | not (exprIsDupable rhs && contIsDupable case_cont) -- | not (isDeadBinder case_bndr) - | all isDeadBinder bs -- InIds + | all isDeadBinder bs -- InIds + && not (isUnLiftedType (idType case_bndr)) + -- Note [Single-alternative-unlifted] = return (env, mkBoringStop, cont) mkDupableCont env (Select _ case_bndr alts se cont) @@ -1876,10 +1897,10 @@ mkDupableAlt env case_bndr' (con, bndrs', rhs') ; (final_bndrs', final_args) -- Note [Join point abstraction] <- if (any isId used_bndrs') then return (used_bndrs', varsToCoreExprs used_bndrs') - else do { rw_id <- newId FSLIT("w") realWorldStatePrimTy + else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy ; return ([rw_id], [Var realWorldPrimId]) } - ; join_bndr <- newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty') + ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty') -- Note [Funky mkPiTypes] ; let -- We make the lambdas into one-shot-lambdas. The @@ -1892,7 +1913,7 @@ mkDupableAlt env case_bndr' (con, bndrs', rhs') join_rhs = mkLams really_final_bndrs rhs' join_call = mkApps (Var join_bndr) final_args - ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) } + ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) } -- See Note [Duplicated env] \end{code} @@ -2061,3 +2082,37 @@ Other choices: When x is inlined into its full context, we find that it was a bad idea to have pushed the outer case inside the (...) case. +Note [Single-alternative-unlifted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's another single-alternative where we really want to do case-of-case: + +data Mk1 = Mk1 Int# +data Mk1 = Mk2 Int# + +M1.f = + \r [x_s74 y_s6X] + case + case y_s6X of tpl_s7m { + M1.Mk1 ipv_s70 -> ipv_s70; + M1.Mk2 ipv_s72 -> ipv_s72; + } + of + wild_s7c + { __DEFAULT -> + case + case x_s74 of tpl_s7n { + M1.Mk1 ipv_s77 -> ipv_s77; + M1.Mk2 ipv_s79 -> ipv_s79; + } + of + wild1_s7b + { __DEFAULT -> ==# [wild1_s7b wild_s7c]; + }; + }; + +So the outer case is doing *nothing at all*, other than serving as a +join-point. In this case we really want to do case-of-case and decide +whether to use a real join point or just duplicate the continuation. + +Hence: check whether the case binder's type is unlifted, because then +the outer case is *not* a seq.