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 )
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 )
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 )
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)
-> 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) }
-- 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
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)
-- 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 }
(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
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
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]
= 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
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
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)
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')
| 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
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]
~~~~~~~~~~~~~~~~~~~~~
mkDupableCont returns a pair of continuations.
-Note [Single-alternative cases]
+Note [Single-atlernative cases]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This case is just like the ArgOf case. Here's an example:
data T a = MkT !a
"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,
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...
projects / ghc-hetmet.git / blobdiff