let
(env2,bndr2) = addLetIdInfo env1 bndr bndr1
in
- if needsCaseBinding bndr_ty rhs1
- then
- thing_inside env2 `thenSmpl` \ (floats, body) ->
- returnSmpl (emptyFloats env2, Case rhs1 bndr2 (exprType body)
- [(DEFAULT, [], wrapFloats floats body)])
- else
- completeNonRecX env2 True {- strict -} bndr bndr2 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
-> SimplM FloatsWithExpr
simplNonRecX env bndr new_rhs thing_inside
- | needsCaseBinding (idType bndr) new_rhs
+ = do { (env, bndr') <- simplBinder env bndr
+ ; completeNonRecX env False {- Non-strict; pessimistic -}
+ bndr bndr' new_rhs thing_inside }
+
+
+completeNonRecX :: SimplEnv
+ -> Bool -- Strict binding
+ -> InId -- Old binder
+ -> OutId -- New binder
+ -> OutExpr -- Simplified RHS
+ -> (SimplEnv -> SimplM FloatsWithExpr)
+ -> SimplM FloatsWithExpr
+
+completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
+ | needsCaseBinding (idType new_bndr) new_rhs
-- Make this test *before* the preInlineUnconditionally
-- Consider case I# (quotInt# x y) of
-- I# v -> let w = J# v in ...
-- extra thunk:
-- let w = J# (quotInt# x y) in ...
-- because quotInt# can fail.
- = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
- thing_inside env `thenSmpl` \ (floats, body) ->
- let body' = wrapFloats floats body in
- returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')])
+ = do { (floats, body) <- thing_inside env
+ ; let body' = wrapFloats floats body
+ ; return (emptyFloats env, Case new_rhs new_bndr (exprType body)
+ [(DEFAULT, [], body')]) }
-{- No, no, no! Do not try preInlineUnconditionally
+ | otherwise
+ = -- Make the arguments atomic if necessary,
+ -- adding suitable bindings
+ -- pprTrace "completeNonRecX" (ppr new_bndr <+> ppr new_rhs) $
+ mkAtomicArgsE env is_strict new_rhs $ \ env new_rhs ->
+ completeLazyBind env NotTopLevel
+ old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) ->
+ addFloats env floats thing_inside
+
+{- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
Doing so risks exponential behaviour, because new_rhs has been simplified once already
In the cases described by the folowing commment, postInlineUnconditionally will
catch many of the relevant cases.
-- If a,b occur once we can avoid constructing the let binding for them.
| preInlineUnconditionally env NotTopLevel bndr new_rhs
= thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
--}
- | otherwise
- = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
- completeNonRecX env False {- Non-strict; pessimistic -}
- bndr bndr' new_rhs thing_inside
-
-completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
- = mkAtomicArgs is_strict
- True {- OK to float unlifted -}
- new_rhs `thenSmpl` \ (aux_binds, rhs2) ->
-
- -- Make the arguments atomic if necessary,
- -- adding suitable bindings
- addAtomicBindsE env (fromOL aux_binds) $ \ env ->
- completeLazyBind env NotTopLevel
- old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) ->
- addFloats env floats thing_inside
+ -- NB: completeLazyBind uses postInlineUnconditionally; no need to do that here
+-}
\end{code}
-- 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 warning
- ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)),
- ppr (filter demanded_float (floatBinds floats)) )
+ WARN( not (is_top_level || not (any demanded_float (floatBinds floats))),
+ ppr (filter demanded_float (floatBinds floats)) )
tick LetFloatFromLet `thenSmpl_` (
addFloats env1 floats $ \ env2 ->
| postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
= -- Drop the binding
tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
+ -- pprTrace "Inline unconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs))
-- Use the substitution to make quite, quite sure that the substitution
-- will happen, since we are going to discard the binding
-- These seqs forces the Id, and hence its IdInfo,
-- and hence any inner substitutions
final_id `seq`
+ -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
returnSmpl (unitFloat env final_id new_rhs, env)
where
context information.
\begin{code}
+mkAtomicArgsE :: SimplEnv
+ -> Bool -- A strict binding
+ -> OutExpr -- The rhs
+ -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
+ -> SimplM FloatsWithExpr
+
+mkAtomicArgsE env is_strict rhs thing_inside
+ | (Var fun, args) <- collectArgs rhs, -- It's an application
+ isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
+ = go env (Var fun) args
+
+ | otherwise = thing_inside env rhs
+
+ where
+ go env fun [] = thing_inside env fun
+
+ go env fun (arg : args)
+ | exprIsTrivial arg -- Easy case
+ || no_float_arg -- Can't make it atomic
+ = go env (App fun arg) args
+
+ | otherwise
+ = do { arg_id <- newId FSLIT("a") arg_ty
+ ; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env ->
+ go env (App fun (Var arg_id)) args }
+ where
+ arg_ty = exprType arg
+ no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg)
+
+
+-- Old code: consider rewriting to be more like mkAtomicArgsE
+
mkAtomicArgs :: Bool -- A strict binding
-> Bool -- OK to float unlifted args
-> OutExpr
addAtomicBinds env [] thing_inside = thing_inside env
addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env ->
addAtomicBinds env bs thing_inside
-
-addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
- -> (SimplEnv -> SimplM FloatsWithExpr)
- -> SimplM FloatsWithExpr
--- Same again, but this time we're in an expression context,
--- and may need to do some case bindings
-
-addAtomicBindsE env [] thing_inside
- = thing_inside env
-addAtomicBindsE env ((v,r):bs) thing_inside
- | needsCaseBinding (idType v) r
- = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) ->
- WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
- (let body = wrapFloats floats expr in
- returnSmpl (emptyFloats env, Case r v (exprType body) [(DEFAULT,[],body)]))
-
- | otherwise
- = addAuxiliaryBind env (NonRec v r) $ \ env ->
- addAtomicBindsE env bs thing_inside
\end{code}
| Just (con,args) <- exprIsConApp_maybe scrut
-- Works when the scrutinee is a variable with a known unfolding
-- as well as when it's an explicit constructor application
- = knownCon env (DataAlt con) args case_bndr alts cont
+ = knownCon env scrut (DataAlt con) args case_bndr alts cont
| Lit lit <- scrut -- No need for same treatment as constructors
-- because literals are inlined more vigorously
- = knownCon env (LitAlt lit) [] case_bndr alts cont
+ = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
| otherwise
= -- Prepare the continuation;
-- Failed try [see Note 2 above]
-- not (isEvaldUnfolding (idUnfolding v))
- = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') ->
+ = simplBinder env (zapOccInfo case_bndr) `thenSmpl` \ (env, case_bndr') ->
returnSmpl (modifyInScope env v case_bndr', case_bndr')
-- 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.
- where
- zap b = b `setIdOccInfo` NoOccInfo
simplCaseBinder env other_scrut case_bndr
= simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
returnSmpl (env, case_bndr')
+
+zapOccInfo :: InId -> InId
+zapOccInfo b = b `setIdOccInfo` NoOccInfo
\end{code}
-- If the case binder is alive, then we add the unfolding
-- case_bndr = C vs
-- to the envt; so vs are now very much alive
+ -- Note [Aug06] I can't see why this actually matters
zap_occ_info | isDeadBinder case_bndr' = \id -> id
- | otherwise = \id -> id `setIdOccInfo` NoOccInfo
+ | otherwise = zapOccInfo
mk_rhs_env env case_bndr' case_bndr_unf
= modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf)
All this should happen in one sweep.
\begin{code}
-knownCon :: SimplEnv -> AltCon -> [OutExpr]
+knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
-> InId -> [InAlt] -> SimplCont
-> SimplM FloatsWithExpr
-knownCon env con args bndr alts cont
- = tick (KnownBranch bndr) `thenSmpl_`
+knownCon env scrut con args bndr alts cont
+ = tick (KnownBranch bndr) `thenSmpl_`
case findAlt con alts of
(DEFAULT, bs, rhs) -> ASSERT( null bs )
simplNonRecX env bndr scrut $ \ env ->
- -- This might give rise to a binding with non-atomic args
- -- like x = Node (f x) (g x)
- -- but no harm will be done
+ -- This might give rise to a binding with non-atomic args
+ -- like x = Node (f x) (g x)
+ -- but simplNonRecX will atomic-ify it
simplExprF env rhs cont
- where
- scrut = case con of
- LitAlt lit -> Lit lit
- DataAlt dc -> mkConApp dc args
(LitAlt lit, bs, rhs) -> ASSERT( null bs )
- simplNonRecX env bndr (Lit lit) $ \ env ->
+ simplNonRecX env bndr scrut $ \ env ->
simplExprF env rhs cont
(DataAlt dc, bs, rhs)
-> ASSERT( n_drop_tys + length bs == length args )
- bind_args env bs (drop n_drop_tys args) $ \ env ->
+ bind_args env dead_bndr bs (drop n_drop_tys args) $ \ env ->
let
- con_app = mkConApp dc (take n_drop_tys args ++ con_args)
+ -- It's useful to bind bndr to scrut, rather than to a fresh
+ -- binding x = Con arg1 .. argn
+ -- because very often the scrut is a variable, so we avoid
+ -- creating, and then subsequently eliminating, a let-binding
+ -- BUT, if scrut is a not a variable, we must be careful
+ -- about duplicating the arg redexes; in that case, make
+ -- a new con-app from the args
+ bndr_rhs = case scrut of
+ Var v -> scrut
+ other -> con_app
+ con_app = mkConApp dc (take n_drop_tys args ++ con_args)
con_args = [substExpr env (varToCoreExpr b) | b <- bs]
-- args are aready OutExprs, but bs are InIds
in
- simplNonRecX env bndr con_app $ \ env ->
+ simplNonRecX env bndr bndr_rhs $ \ env ->
simplExprF env rhs cont
where
+ dead_bndr = isDeadBinder bndr
n_drop_tys | isVanillaDataCon dc = tyConArity (dataConTyCon dc)
| otherwise = 0
-- Vanilla data constructors lack type arguments in the pattern
-- Ugh!
-bind_args env [] _ thing_inside = thing_inside env
+bind_args env dead_bndr [] _ thing_inside = thing_inside env
-bind_args env (b:bs) (Type ty : args) thing_inside
+bind_args env dead_bndr (b:bs) (Type ty : args) thing_inside
= ASSERT( isTyVar b )
- bind_args (extendTvSubst env b ty) bs args thing_inside
+ bind_args (extendTvSubst env b ty) dead_bndr bs args thing_inside
-bind_args env (b:bs) (arg : args) thing_inside
+bind_args env dead_bndr (b:bs) (arg : args) thing_inside
= ASSERT( isId b )
- simplNonRecX env b arg $ \ env ->
- bind_args env bs args thing_inside
+ let
+ b' = if dead_bndr then b else zapOccInfo b
+ -- Note that the binder might be "dead", because it doesn't occur
+ -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
+ -- Nevertheless we must keep it if the case-binder is alive, because it may
+ -- be used in teh con_app
+ in
+ simplNonRecX env b' arg $ \ env ->
+ bind_args env dead_bndr bs args thing_inside
\end{code}
; (floats2, arg2) <- mkDupableArg env arg1
; return (floats2, (ApplyTo OkToDup arg2 Nothing dup_cont, nondup_cont)) }}
+mkDupableCont env cont@(Select _ case_bndr [(_,bs,rhs)] se case_cont)
+-- | not (exprIsDupable rhs && contIsDupable case_cont) -- See notes below
+-- | not (isDeadBinder case_bndr)
+ | all isDeadBinder bs
+ = returnSmpl (emptyFloats env, (mkBoringStop scrut_ty, cont))
+ where
+ scrut_ty = substTy se (idType case_bndr)
+
+{- Note [Single-alternative cases]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This case is just like the ArgOf case. Here's an example:
+ data T a = MkT !a
+ ...(MkT (abs x))...
+Then we get
+ case (case x of I# x' ->
+ case x' <# 0# of
+ True -> I# (negate# x')
+ False -> I# x') of y {
+ DEFAULT -> MkT y
+Because the (case x) has only one alternative, we'll transform to
+ case x of I# x' ->
+ case (case x' <# 0# of
+ True -> I# (negate# x')
+ False -> I# x') of y {
+ DEFAULT -> MkT y
+But now we do *NOT* want to make a join point etc, giving
+ case x of I# x' ->
+ let $j = \y -> MkT y
+ in case x' <# 0# of
+ True -> $j (I# (negate# x'))
+ False -> $j (I# x')
+In this case the $j will inline again, but suppose there was a big
+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*;
+ e.g. case (case ....) of (a,b) -> (# a,b #)
+ We must push the outer case into the inner one!
+Other choices:
+
+ * Match [(DEFAULT,_,_)], but in the common case of Int,
+ the alternative-filling-in code turned the outer case into
+ case (...) of y { I# _ -> MkT y }
+
+ * Match on single alternative plus (not (isDeadBinder case_bndr))
+ Rationale: pushing the case inwards won't eliminate the construction.
+ But there's a risk of
+ case (...) of y { (a,b) -> let z=(a,b) in ... }
+ Now y looks dead, but it'll come alive again. Still, this
+ seems like the best option at the moment.
+
+ * Match on single alternative plus (all (isDeadBinder bndrs))
+ Rationale: this is essentially seq.
+
+ * Match when the rhs is *not* duplicable, and hence would lead to a
+ join point. This catches the disaster-case above. We can test
+ 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!
+
+ HOWEVER: I found that this version doesn't work well, because
+ we can get let x = case (...) of { small } in ...case x...
+ 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.
+-}
+
mkDupableCont env (Select _ case_bndr alts se cont)
= -- e.g. (case [...hole...] of { pi -> ei })
-- ===>
projects / ghc-hetmet.git / blobdiff