)
import Var ( mustHaveLocalBinding )
import VarEnv
-import Id ( Id, idType, idInfo, idArity, isDataConId,
+import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda,
)
import OccName ( encodeFS )
import IdInfo ( OccInfo(..), isLoopBreaker,
- setArityInfo,
+ setArityInfo, zapDemandInfo,
setUnfoldingInfo,
occInfo
)
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsValue,
exprOkForSpeculation, exprArity,
- mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
+ mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, eqType
)
-import Subst ( mkSubst, substTy, substExpr,
+import Subst ( mkSubst, substTy, substExpr,
isInScope, lookupIdSubst, simplIdInfo
)
import TysPrim ( realWorldStatePrimTy )
)
import OrdList
import Maybe ( Maybe )
+import Maybes ( orElse )
import Outputable
+import Util ( notNull )
\end{code}
drop_bs (NonRec _ _) (_ : bs) = bs
drop_bs (Rec prs) bs = drop (length prs) bs
- simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
- simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
+ simpl_bind env bind bs
+ = getDOptsSmpl `thenSmpl` \ dflags ->
+ if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs
+ else
+ simpl_bind1 env bind bs
+
+ simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
+ simpl_bind1 env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
\end{code}
| isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence info in the substitution
- simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
+ simplLetBndr env bndr `thenSmpl` \ (env, bndr1) ->
+ simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 ->
+
+ -- Now complete the binding and simplify the body
let
-- simplLetBndr doesn't deal with the IdInfo, so we must
-- do so here (c.f. simplLazyBind)
- bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
- env1 = modifyInScope env bndr'' bndr''
+ bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
+ env2 = modifyInScope env1 bndr2 bndr2
in
- simplStrictArg AnRhs env1 rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 ->
-
- -- Now complete the binding and simplify the body
- completeNonRecX env True {- strict -} bndr bndr'' rhs1 thing_inside
+ completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
| otherwise -- Normal, lazy case
= -- Don't use simplBinder because that doesn't keep
-> InExpr -> SimplEnv -- The RHS and its environment
-> SimplM (FloatsWith SimplEnv)
-simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
- = -- Substitute IdInfo on binder, in the light of earlier
- -- substitutions in this very letrec, and extend the
- -- in-scope env, so that the IdInfo for this binder extends
- -- over the RHS for the binder itself.
+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
+ = let -- Transfer the IdInfo of the original binder to the new binder
+ -- This is crucial: we must preserve
+ -- strictness
+ -- rules
+ -- worker info
+ -- etc. To do this we must apply the current substitution,
+ -- which incorporates earlier substitutions in this very letrec group.
--
+ -- NB 1. We do this *before* processing the RHS of the binder, so that
+ -- its substituted rules are visible in its own RHS.
-- This is important. Manuel found cases where he really, really
-- wanted a RULE for a recursive function to apply in that function's
- -- own right-hand side.
+ -- own right-hand side.
--
- -- NB: does no harm for non-recursive bindings
- let
- bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
- env1 = modifyInScope env bndr'' bndr''
+ -- NB 2: We do not transfer the arity (see Subst.substIdInfo)
+ -- The arity of an Id should not be visible
+ -- in its own RHS, else we eta-reduce
+ -- f = \x -> f x
+ -- to
+ -- f = f
+ -- which isn't sound. And it makes the arity in f's IdInfo greater than
+ -- the manifest arity, which isn't good.
+ -- The arity will get added later.
+ --
+ -- NB 3: It's important that we *do* transer the loop-breaker OccInfo,
+ -- because that's what stops the Id getting inlined infinitely, in the body
+ -- of the letrec.
+
+ -- NB 4: does no harm for non-recursive bindings
+
+ bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
+ env1 = modifyInScope env bndr2 bndr2
rhs_env = setInScope rhs_se env1
is_top_level = isTopLevel top_lvl
ok_float_unlifted = not is_top_level && isNonRec is_rec
- rhs_cont = mkStop (idType bndr') AnRhs
+ rhs_cont = mkStop (idType bndr1) AnRhs
in
-- Simplify the RHS; note the mkStop, which tells
-- the simplifier that this is the RHS of a let.
-- If any of the floats can't be floated, give up now
-- (The allLifted predicate says True for empty floats.)
if (not ok_float_unlifted && not (allLifted floats)) then
- completeLazyBind env1 top_lvl bndr bndr''
+ completeLazyBind env1 top_lvl bndr bndr2
(wrapFloats floats rhs1)
else
-- If the result is a PAP, float the floats out, else wrap them
-- By this time it's already been ANF-ised (if necessary)
if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case
- completeLazyBind env1 top_lvl bndr bndr'' rhs2
+ completeLazyBind env1 top_lvl bndr bndr2 rhs2
- -- We use exprIsTrivial here because we want to reveal lone variables.
- -- E.g. let { x = letrec { y = E } in y } in ...
- -- Here we definitely want to float the y=E defn.
- -- exprIsValue definitely isn't right for that.
- --
- -- BUT we can't use "exprIsCheap", because that causes a strictness bug.
+ else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+ -- WARNING: long dodgy argument coming up
+ -- WANTED: a better way to do this
+ --
+ -- We can't use "exprIsCheap" instead of exprIsValue,
+ -- because that causes a strictness bug.
-- x = let y* = E in case (scc y) of { T -> F; F -> T}
-- The case expression is 'cheap', but it's wrong to transform to
-- y* = E; x = case (scc y) of {...}
-- Either we must be careful not to float demanded non-values, or
-- we must use exprIsValue for the test, which ensures that the
- -- thing is non-strict. I think. The WARN below tests for this.
- else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+ -- thing is non-strict. So exprIsValue => bindings are non-strict
+ -- I think. The WARN below tests for this.
+ --
+ -- We use exprIsTrivial here because we want to reveal lone variables.
+ -- E.g. let { x = letrec { y = E } in y } in ...
+ -- Here we definitely want to float the y=E defn.
+ -- exprIsValue definitely isn't right for that.
+ --
+ -- Again, the floated binding can't be strict; if it's recursive it'll
+ -- be non-strict; if it's non-recursive it'd be inlined.
+ --
+ -- Note [SCC-and-exprIsTrivial]
+ -- If we have
+ -- y = let { x* = E } in scc "foo" x
+ -- then we do *not* want to float out the x binding, because
+ -- it's strict! Fortunately, exprIsTrivial replies False to
+ -- (scc "foo" x).
-- There's a subtlety here. There may be a binding (x* = e) in the
-- floats, where the '*' means 'will be demanded'. So is it safe
-- to float it out? Answer no, but it won't matter because
- -- we only float if arg' is a WHNF,
+ -- we only float if (a) arg' is a WHNF, or (b) it's going to top level
-- and so there can't be any 'will be demanded' bindings in the floats.
- -- Hence the assert
- WARN( any demanded_float (floatBinds floats),
- ppr (filter demanded_float (floatBinds floats)) )
+ -- Hence the warning
+ ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)),
+ ppr (filter demanded_float (floatBinds floats)) )
tick LetFloatFromLet `thenSmpl_` (
addFloats env1 floats $ \ env2 ->
addAtomicBinds env2 (fromOL aux_binds) $ \ env3 ->
- completeLazyBind env3 top_lvl bndr bndr'' rhs2)
+ completeLazyBind env3 top_lvl bndr bndr2 rhs2)
else
- completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
+ completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1)
#ifdef DEBUG
demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
-- Add arity info
new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
- -- Add the unfolding *only* for non-loop-breakers
- -- Making loop breakers not have an unfolding at all
- -- means that we can avoid tests in exprIsConApp, for example.
- -- This is important: if exprIsConApp says 'yes' for a recursive
- -- thing, then we can get into an infinite loop
- info_w_unf | loop_breaker = new_bndr_info
- | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
- unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
-
- final_id = new_bndr `setIdInfo` info_w_unf
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing, then we can get into an infinite loop
+
+ -- If the unfolding is a value, the demand info may
+ -- go pear-shaped, so we nuke it. Example:
+ -- let x = (a,b) in
+ -- case x of (p,q) -> h p q x
+ -- Here x is certainly demanded. But after we've nuked
+ -- the case, we'll get just
+ -- let x = (a,b) in h a b x
+ -- and now x is not demanded (I'm assuming h is lazy)
+ -- This really happens. Similarly
+ -- let f = \x -> e in ...f..f...
+ -- After inling f at some of its call sites the original binding may
+ -- (for example) be no longer strictly demanded.
+ -- The solution here is a bit ad hoc...
+ unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+ info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
+ final_info | loop_breaker = new_bndr_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
simplExprF env (Let (Rec pairs) body) cont
= simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
- -- NB: bndrs' don't have unfoldings or spec-envs
- -- We add them as we go down, using simplPrags
+ -- NB: bndrs' don't have unfoldings or rules
+ -- We add them as we go down
simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
addFloats env floats $ \ env ->
-- the inner one is redundant
addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
- | Just (s1, s2) <- splitFunTy_maybe s1s2
+ | not (isTypeArg arg), -- This whole case only works for value args
+ -- Could upgrade to have equiv thing for type apps too
+ Just (s1, s2) <- splitFunTy_maybe s1s2
-- (coerce (T1->T2) (S1->S2) F) E
-- ===>
-- coerce T2 S2 (F (coerce S1 T1 E))
--
- -- t1t2 must be a function type, T1->T2
+ -- t1t2 must be a function type, T1->T2, because it's applied to something
-- but s1s2 might conceivably not be
--
-- When we build the ApplyTo we can't mix the out-types
-- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
- new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
+ new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
in
ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
-- an interesting context of any kind to combine with
-- (even a type application -- anything except Stop)
= simplExprF env e cont
+
+simplNote env (CoreNote s) e cont
+ = simplExpr env e `thenSmpl` \ e' ->
+ rebuild env (Note (CoreNote s) e') cont
\end{code}
tick (RuleFired rule_name) `thenSmpl_`
(if dopt Opt_D_dump_inlinings dflags then
pprTrace "Rule fired" (vcat [
- text "Rule:" <+> ptext rule_name,
+ text "Rule:" <+> ftext rule_name,
text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
text "After: " <+> pprCoreExpr rule_rhs,
text "Cont: " <+> ppr call_cont])
let
arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
- interesting_cont = interestingCallContext (not (null args))
- (not (null arg_infos))
+ interesting_cont = interestingCallContext (notNull args)
+ (notNull arg_infos)
call_cont
active_inline = activeInline env var occ_info
| is_strict
= simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside
- | otherwise
- = simplExprF (setInScope arg_se env) val_arg
- (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) ->
- addFloats env floats $ \ env ->
- thing_inside env arg1
+ | otherwise -- Lazy argument
+ -- DO NOT float anything outside, hence simplExprC
+ -- There is no benefit (unlike in a let-binding), and we'd
+ -- have to be very careful about bogus strictness through
+ -- floating a demanded let.
+ = simplExprC (setInScope arg_se env) val_arg
+ (mkStop arg_ty AnArg) `thenSmpl` \ arg1 ->
+ thing_inside env arg1
where
arg_ty = funArgTy fn_ty
-- if the strict-binding flag is on
mkAtomicArgs is_strict ok_float_unlifted rhs
- | (Var fun, args) <- collectArgs rhs, -- It's an application
- isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
+ | (Var fun, args) <- collectArgs rhs, -- It's an application
+ isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
= go fun nilOL [] args -- Have a go
| otherwise = bale_out -- Give up
rebuild env expr (Stop _ _ _) = rebuildDone env expr
rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
-rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
+rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty expr) cont
rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
| otherwise
= prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
-
+
-- Deal with the case binder, and prepare the continuation;
-- The new subst_env is in place
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
-- We really must record that b is already evaluated so that we don't
-- go and re-evaluate it when constructing the result.
- add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
+ add_evals (DataAlt dc) vs = cat_evals dc vs (dataConRepStrictness dc)
add_evals other_con vs = vs
- cat_evals [] [] = []
- cat_evals (v:vs) (str:strs)
- | isTyVar v = v : cat_evals vs (str:strs)
- | isMarkedStrict str = evald_v : cat_evals vs strs
- | otherwise = zapped_v : cat_evals vs strs
+ cat_evals dc vs strs
+ = go vs strs
where
- zapped_v = zap_occ_info v
- evald_v = zapped_v `setIdUnfolding` mkOtherCon []
+ go [] [] = []
+ go (v:vs) (str:strs)
+ | isTyVar v = v : go vs (str:strs)
+ | isMarkedStrict str = evald_v : go vs strs
+ | otherwise = zapped_v : go vs strs
+ where
+ zapped_v = zap_occ_info v
+ evald_v = zapped_v `setIdUnfolding` mkOtherCon []
+ go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
\end{code}
) `thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
- newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
+ newId (encodeFS FSLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
-- Notice the funky mkPiTypes. If the contructor has existentials
-- it's possible that the join point will be abstracted over
-- type varaibles as well as term variables.
projects / ghc-hetmet.git / blobdiff