X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=379fce155509bb9633067c023e9f82b7dafe7a0e;hb=a06cc26192b0df5726e7ae201e94379c734423fc;hp=d2f3d965f8d49eeb2c94b10fa63d392478eeff88;hpb=71c7067b7cc2b06265c97190e6a09c272ad7a175;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index d2f3d96..379fce1 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 ) @@ -27,8 +28,9 @@ import CoreMonad ( SimplifierSwitch(..), Tick(..) ) import CoreSyn import Demand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, - exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) +import CoreUnfold ( mkUnfolding, mkCoreUnfolding + , mkInlineUnfolding, mkSimpleUnfolding + , exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) import CoreUtils import qualified CoreSubst import CoreArity ( exprArity ) @@ -36,7 +38,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 ) @@ -562,7 +563,7 @@ makeTrivialWithInfo top_lvl env info expr expr_ty = exprType expr bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool --- True iff we can have a binding of this expression at this leve +-- 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) @@ -705,15 +706,15 @@ 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 simplUnfolding env top_lvl id _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_src = src, uf_guidance = guide }) - | isInlineRuleSource src + | isStableSource src = do { expr' <- simplExpr rule_env expr ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } @@ -724,7 +725,7 @@ simplUnfolding env top_lvl id _ _ -- See Note [Simplifying gently inside InlineRules] in SimplUtils simplUnfolding _ top_lvl id _occ_info new_rhs _ - = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs) + = return (mkUnfolding InlineRhs (isTopLevel top_lvl) (isBottomingId id) new_rhs) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF -- (b) In TidyPgm we currently assume that, if we want to @@ -877,7 +878,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) @@ -1081,7 +1082,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 } @@ -1095,7 +1096,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 @@ -1137,7 +1138,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 @@ -1503,7 +1504,7 @@ rebuildCase env scrut case_bndr alts cont rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont -- See if we can get rid of the case altogether - -- See Note [Case eliminiation] + -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, -- then there is now only one (DEFAULT) rhs | all isDeadBinder bndrs -- bndrs are [InId] @@ -1768,7 +1769,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 @@ -1789,7 +1790,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv addBinderUnfolding env bndr rhs - = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs) + = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs) addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons @@ -1843,7 +1844,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) @@ -2016,7 +2017,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points] - unf = mkInlineRule rhs Nothing + unf = mkInlineUnfolding Nothing rhs rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs') @@ -2030,7 +2031,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 @@ -2271,10 +2272,14 @@ strict computation enclosing the orginal call to MkT. Then, it won't "see" the MkT any more, because it's big and won't get duplicated. And, what is worse, nothing was gained by the case-of-case transform. -When should use this case of mkDupableCont? -However, matching on *any* single-alternative case is a *disaster*; +So, in circumstances like these, we don't want to build join points +and push the outer case into the branches of the inner one. Instead, +don't duplicate the continuation. + +When should we use this strategy? We should not use it on *every* +single-alternative case: e.g. case (case ....) of (a,b) -> (# a,b #) - We must push the outer case into the inner one! +Here we must push the outer case into the inner one! Other choices: * Match [(DEFAULT,_,_)], but in the common case of Int, @@ -2296,7 +2301,7 @@ Other choices: the *un-simplified* rhs, which is fine. It might get bigger or smaller after simplification; if it gets smaller, this case might fire next time round. NB also that we must test contIsDupable - case_cont *btoo, because case_cont might be big! + case_cont *too, because case_cont might be big! HOWEVER: I found that this version doesn't work well, because we can get let x = case (...) of { small } in ...case x...