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')]) }
+
+ | 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
+{- 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.
-- NB: completeLazyBind uses postInlineUnconditionally; no need to do that here
-}
-
- | 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
\end{code}
| 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}
-- 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)
(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
-- It's useful to bind bndr to scrut, rather than to a fresh
-- binding x = Con arg1 .. argn
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
--- Note that the binder might be "dead", because it doesn't occur in the RHS
--- Nevertheless we bind it here, in case we need it for the con_app for the case_bndr
+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}
projects / ghc-hetmet.git / blobdiff