import Type hiding ( substTy, extendTvSubst )
import SimplEnv
import SimplUtils
-import Literal ( mkStringLit )
import MkId ( rUNTIME_ERROR_ID )
import Id
import Var
import FamInstEnv ( topNormaliseType )
import DataCon ( dataConRepStrictness, dataConUnivTyVars )
import CoreSyn
-import NewDemand ( isStrictDmd )
+import NewDemand ( isStrictDmd, splitStrictSig )
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
import CoreUtils
-import Rules ( lookupRule )
+import Rules ( lookupRule, getRules )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import TysPrim ( realWorldStatePrimTy )
import Maybes ( orElse )
import Data.List ( mapAccumL )
import Outputable
-import MonadUtils
import FastString
\end{code}
; env1 <- go (zapFloats env_with_info) triples
; return (env0 `addRecFloats` env1) }
-- addFloats adds the floats from env1,
- -- *and* updates env0 with the in-scope set from env1
+ -- _and_ updates env0 with the in-scope set from env1
where
add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
-- Add the (substituted) rules to the binder
do { tick LetFloatFromLet
; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
; rhs' <- mkLam tvs' body3
- ; env' <- foldlM add_poly_bind env poly_binds
+ ; let env' = foldl (addPolyBind top_lvl) env poly_binds
; return (env', rhs') }
; completeBind env' top_lvl bndr bndr1 rhs' }
- where
- add_poly_bind env (NonRec poly_id rhs)
- = completeBind env top_lvl poly_id poly_id rhs
- -- completeBind adds the new binding in the
- -- proper way (ie complete with unfolding etc),
- -- and extends the in-scope set
- add_poly_bind env bind@(Rec _)
- = return (extendFloats env bind)
- -- Hack: letrecs are more awkward, so we extend "by steam"
- -- without adding unfoldings etc. At worst this leads to
- -- more simplifier iterations
\end{code}
A specialised variant of simplNonRec used when the RHS is already simplified,
= do { var <- newId (fsLit "a") (exprType expr)
; env' <- completeNonRecX env False var var expr
; return (env', substExpr env' (Var var)) }
+ -- The substitution is needed becase we're constructing a new binding
+ -- a = rhs
+ -- And if rhs is of form (rhs1 |> co), then we might get
+ -- a1 = rhs1
+ -- a = a1 |> co
+ -- and now a's RHS is trivial and can be substituted out, and that
+ -- is what completeNonRecX will do
\end{code}
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
- | otherwise
- = let
+ | otherwise
+ = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
+ where
+ unfolding | omit_unfolding = NoUnfolding
+ | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+ wkr = substWorker env (workerInfo old_info)
+ omit_unfolding = isNonRuleLoopBreaker occ_info
+ -- or not (activeInline env old_bndr)
+ -- Do *not* trim the unfolding in SimplGently, else
+ -- the specialiser can't see it!
+
+-----------------
+addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
+-- Add a new binding to the environment, complete with its unfolding
+-- but *do not* do postInlineUnconditionally, because we have already
+-- processed some of the scope of the binding
+-- We still want the unfolding though. Consider
+-- let
+-- x = /\a. let y = ... in Just y
+-- in body
+-- Then we float the y-binding out (via abstractFloats and addPolyBind)
+-- but 'x' may well then be inlined in 'body' in which case we'd like the
+-- opportunity to inline 'y' too.
+
+addPolyBind top_lvl env (NonRec poly_id rhs)
+ = addNonRecWithUnf env poly_id rhs unfolding NoWorker
+ where
+ unfolding | not (activeInline env poly_id) = NoUnfolding
+ | otherwise = mkUnfolding (isTopLevel top_lvl) rhs
+ -- addNonRecWithInfo adds the new binding in the
+ -- proper way (ie complete with unfolding etc),
+ -- and extends the in-scope set
+
+addPolyBind _ env bind@(Rec _) = extendFloats env bind
+ -- Hack: letrecs are more awkward, so we extend "by steam"
+ -- without adding unfoldings etc. At worst this leads to
+ -- more simplifier iterations
+
+-----------------
+addNonRecWithUnf :: SimplEnv
+ -> OutId -> OutExpr -- New binder and RHS
+ -> Unfolding -> WorkerInfo -- and unfolding
+ -> SimplEnv
+-- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
+addNonRecWithUnf env new_bndr rhs unfolding wkr
+ = ASSERT( isId new_bndr )
+ WARN( new_arity < old_arity || new_arity < dmd_arity,
+ (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
+ final_id `seq` -- This seq forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ addNonRec env final_id rhs
+ -- The addNonRec adds it to the in-scope set too
+ where
+ dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
+ old_arity = idArity new_bndr
+
-- Arity info
- new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+ new_arity = exprArity rhs
+ new_bndr_info = idInfo new_bndr `setArityInfo` new_arity
-- Unfolding info
-- Add the unfolding *only* for non-loop-breakers
-- (for example) be no longer strictly demanded.
-- The solution here is a bit ad hoc...
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
- `setWorkerInfo` worker_info
+ `setWorkerInfo` wkr
- final_info | omit_unfolding = new_bndr_info
- | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
+ final_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
- final_id `seq`
- -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
- return (addNonRec env final_id new_rhs)
- -- The addNonRec adds it to the in-scope set too
- where
- unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
- worker_info = substWorker env (workerInfo old_info)
- omit_unfolding = isNonRuleLoopBreaker occ_info || not (activeInline env old_bndr)
- old_info = idInfo old_bndr
- occ_info = occInfo old_info
\end{code}
add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
| (_l1, t1) <- coercionKind co2
- -- coerce T1 S1 (coerce S1 K1 e)
+ -- e |> (g1 :: S1~L) |> (g2 :: L~T1)
-- ==>
- -- e, if T1=K1
- -- coerce T1 K1 e, otherwise
+ -- e, if T1=T2
+ -- e |> (g1 . g2 :: T1~T2) otherwise
--
-- For example, in the initial form of a worker
-- we may find (coerce T (coerce S (\x.e))) y
| otherwise = CoerceIt (mkTransCoercion co1 co2) cont
add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
- -- (f `cast` g) ty ---> (f ty) `cast` (g @ ty)
+ -- (f |> g) ty ---> (f ty) |> (g @ ty)
-- This implements the PushT rule from the paper
| Just (tyvar,_) <- splitForAllTy_maybe s1s2
, not (isCoVar tyvar)
add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
| not (isTypeArg arg) -- This implements the Push rule from the paper
, isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
- -- co : s1s2 :=: t1t2
- -- (coerce (T1->T2) (S1->S2) F) E
+ -- (e |> (g :: s1s2 ~ t1->t2)) f
-- ===>
- -- coerce T2 S2 (F (coerce S1 T1 E))
+ -- (e (f |> (arg g :: t1~s1))
+ -- |> (res g :: s2->t2)
--
- -- t1t2 must be a function type, T1->T2, because it's applied
+ -- 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
-- Example of use: Trac #995
= ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
where
- -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and
- -- t2 :=: s2 with left and right on the curried form:
- -- (->) t1 t2 :=: (->) s1 s2
+ -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
+ -- t2 ~ s2 with left and right on the curried form:
+ -- (->) t1 t2 ~ (->) s1 s2
[co1, co2] = decomposeCo 2 co
new_arg = mkCoerce (mkSymCoercion co1) arg'
arg' = substExpr (arg_se `setInScope` env) arg
(StrictBind bndr bndrs body env cont) }
| otherwise
- = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ = ASSERT( not (isTyVar bndr) )
+ do { (env1, bndr1) <- simplNonRecBndr env bndr
; let (env2, bndr2) = addBndrRules env1 bndr bndr1
; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
; simplLam env3 bndrs body cont }
-- is recursive, and hence a loop breaker:
-- foldr k z (build g) = g k z
-- So it's up to the programmer: rules can cause divergence
- ; rules <- getRules
+ ; rule_base <- getSimplRules
; let in_scope = getInScope env
+ rules = getRules rule_base var
maybe_rule = case activeRule dflags env of
Nothing -> Nothing -- No rules apply
Just act_fn -> lookupRule act_fn in_scope
- rules var args
+ var args rules
; case maybe_rule of {
Just (rule, rule_rhs) -> do
tick (RuleFired (ru_name rule))
-- inaccessible. So we simply put an error case here instead.
pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
let res_ty' = contResultType env' (substTy env' (coreAltsType alts)) dup_cont
- lit = Lit (mkStringLit "Impossible alternative")
+ lit = mkStringLit "Impossible alternative"
in return (env', mkApps (Var rUNTIME_ERROR_ID) [Type res_ty', lit])
else do
; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env') dup_cont
; return (env'', app_cont, nodup_cont) }
-mkDupableCont env cont@(Select _ _ [(_, bs, _rhs)] _ _)
+mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
-- See Note [Single-alternative case]
-- | not (exprIsDupable rhs && contIsDupable case_cont)
-- | not (isDeadBinder case_bndr)
- | all isDeadBinder bs -- InIds
+ | all isDeadBinder bs -- InIds
+ && not (isUnLiftedType (idType case_bndr))
+ -- Note [Single-alternative-unlifted]
= return (env, mkBoringStop, cont)
mkDupableCont env (Select _ case_bndr alts se cont)
join_rhs = mkLams really_final_bndrs rhs'
join_call = mkApps (Var join_bndr) final_args
- ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) }
+ ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) }
-- See Note [Duplicated env]
\end{code}
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.
+Note [Single-alternative-unlifted]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here's another single-alternative where we really want to do case-of-case:
+
+data Mk1 = Mk1 Int#
+data Mk1 = Mk2 Int#
+
+M1.f =
+ \r [x_s74 y_s6X]
+ case
+ case y_s6X of tpl_s7m {
+ M1.Mk1 ipv_s70 -> ipv_s70;
+ M1.Mk2 ipv_s72 -> ipv_s72;
+ }
+ of
+ wild_s7c
+ { __DEFAULT ->
+ case
+ case x_s74 of tpl_s7n {
+ M1.Mk1 ipv_s77 -> ipv_s77;
+ M1.Mk2 ipv_s79 -> ipv_s79;
+ }
+ of
+ wild1_s7b
+ { __DEFAULT -> ==# [wild1_s7b wild_s7c];
+ };
+ };
+
+So the outer case is doing *nothing at all*, other than serving as a
+join-point. In this case we really want to do case-of-case and decide
+whether to use a real join point or just duplicate the continuation.
+
+Hence: check whether the case binder's type is unlifted, because then
+the outer case is *not* a seq.
projects / ghc-hetmet.git / blobdiff