import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap )
+import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap, exprEtaExpandArity )
import Subst ( substBndrs, substBndr, substIds )
import Id ( Id, idType, getIdArity, isId, idName,
- getInlinePragma, setInlinePragma,
- getIdDemandInfo, mkId
+ getIdOccInfo,
+ getIdDemandInfo, mkId, idInfo
)
-import IdInfo ( arityLowerBound, InlinePragInfo(..), setInlinePragInfo, vanillaIdInfo )
+import IdInfo ( arityLowerBound, setOccInfo, vanillaIdInfo )
import Maybes ( maybeToBool, catMaybes )
import Const ( Con(..) )
import Name ( isLocalName, setNameUnique )
import SimplMonad
-import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys,
+import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
)
import TysPrim ( statePrimTyCon )
let
(subst', bndrs') = substBndrs subst bndrs
in
- setSubst subst' $
- thing_inside bndrs'
+ seqBndrs bndrs' `seq`
+ setSubst subst' (thing_inside bndrs')
simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
simplBinder bndr thing_inside
let
(subst', bndr') = substBndr subst bndr
in
- setSubst subst' $
- thing_inside bndr'
+ seqBndr bndr' `seq`
+ setSubst subst' (thing_inside bndr')
-- Same semantics as simplBinders, but a little less
let
(subst', bndrs') = substIds subst ids
in
- setSubst subst' $
- thing_inside bndrs'
+ seqBndrs bndrs' `seq`
+ setSubst subst' (thing_inside bndrs')
+
+seqBndrs [] = ()
+seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+
+seqBndr b | isTyVar b = b `seq` ()
+ | otherwise = seqType (idType b) `seq`
+ idInfo b `seq`
+ ()
\end{code}
poly_name = setNameUnique (idName var) uniq -- Keep same name
poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
- -- It's crucial to copy the inline-prag of the original var, because
+ -- It's crucial to copy the occInfo of the original var, because
-- we're looking at occurrence-analysed but as yet unsimplified code!
-- In particular, we mustn't lose the loop breakers.
--
-- where x* has an INLINE prag on it. Now, once x* is inlined,
-- the occurrences of x' will be just the occurrences originaly
-- pinned on x.
- poly_info = vanillaIdInfo `setInlinePragInfo` getInlinePragma var
+ poly_info = vanillaIdInfo `setOccInfo` getIdOccInfo var
poly_id = mkId poly_name poly_ty poly_info
in
returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
- mk_silly_bind var rhs = NonRec (setInlinePragma var IMustBeINLINEd) rhs
- -- The addInlinePragma is really important! If we don't say
+ mk_silly_bind var rhs = NonRec var rhs
+ -- The Inline note is really important! If we don't say
-- INLINE on these silly little bindings then look what happens!
-- Suppose we start with:
--
-- * but then it gets inlined into the rhs of g*
-- * then the binding for g* is floated out of the /\b
-- * so we're back to square one
- -- The silly binding for g* must be IMustBeINLINEs, so that
+ -- The silly binding for g* must be INLINEd, so that
-- we simply substitute for g* throughout.
\end{code}
wanting a suitable number of extra args.
NB: the Ei may have unlifted type, but the simplifier (which is applied
-to the result) deals OK with this).
+to the result) deals OK with this.
There is no point in looking for a combination of the two,
because that would leave use with some lets sandwiched between lambdas;
(x_bndrs, body) = collectValBinders rhs
(fun, args) = collectArgs body
trivial_args = map exprIsTrivial args
- fun_arity = case fun of
- Var v -> arityLowerBound (getIdArity v)
- other -> 0
+ fun_arity = exprEtaExpandArity fun
bind_z_arg (arg, trivial_arg)
| trivial_arg = returnSmpl (Nothing, arg)
y_tys = take no_extras_wanted potential_extra_arg_tys
no_extras_wanted :: Int
- no_extras_wanted =
+ no_extras_wanted = 0 `max`
-- We used to expand the arity to the previous arity fo the
-- function; but this is pretty dangerous. Consdier
-- (bndr_arity - no_of_xs) `max`
-- See if the body could obviously do with more args
- (fun_arity - valArgCount args) `max`
+ (fun_arity - valArgCount args)
+-- This case is now deal with by exprEtaExpandArity
-- Finally, see if it's a state transformer, and xs is non-null
-- (so it's also a function not a thunk) in which
-- case we eta-expand on principle! This can waste work,
-- \ x -> let {..} in \ s -> f (...) s
-- AND f RETURNED A FUNCTION. That is, 's' wasn't the only
-- potential extra arg.
- case (x_bndrs, potential_extra_arg_tys) of
- (_:_, ty:_) -> case splitTyConApp_maybe ty of
- Just (tycon,_) | tycon == statePrimTyCon -> 1
- other -> 0
- other -> 0
+-- case (x_bndrs, potential_extra_arg_tys) of
+-- (_:_, ty:_) -> case splitTyConApp_maybe ty of
+-- Just (tycon,_) | tycon == statePrimTyCon -> 1
+-- other -> 0
+-- other -> 0
\end{code}
matches (DEFAULT, _, _) = True
matches (con1, _, _) = con == con1
+\end{code}
-mkCoerce to_ty (Note (Coerce _ from_ty) expr)
+\begin{code}
+mkCoerce :: Type -> CoreExpr -> CoreExpr
+mkCoerce to_ty expr
| to_ty == from_ty = expr
| otherwise = Note (Coerce to_ty from_ty) expr
-mkCoerce to_ty expr
- = Note (Coerce to_ty (coreExprType expr)) expr
+ where
+ from_ty = coreExprType expr
\end{code}