\begin{code}
module SimplUtils (
- mkLam, mkCase,
+ mkLam, mkCase,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
import CoreSyn
import CoreFVs ( exprFreeVars )
import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
- etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
- findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts
+ etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
+ findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts,
+ applyTypeToArgs
)
import Literal ( mkStringLit )
import CoreUnfold ( smallEnoughToInline )
-import MkId ( eRROR_ID )
+import MkId ( eRROR_ID, wrapNewTypeBody )
import Id ( Id, idType, isDataConWorkId, idOccInfo, isDictId,
- isDeadBinder, idNewDemandInfo, isExportedId,
+ isDeadBinder, idNewDemandInfo, isExportedId, mkSysLocal,
idUnfolding, idNewStrictness, idInlinePragma, idHasRules
)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
+import Var ( tyVarKind, mkTyVar )
+import Name ( mkSysTvName )
import Type ( Type, splitFunTys, dropForAlls, isStrictType,
- splitTyConApp_maybe, tyConAppArgs
+ splitTyConApp_maybe, tyConAppArgs, mkTyVarTys )
+import Coercion ( isEqPredTy
)
-import TyCon ( tyConDataCons_maybe )
-import DataCon ( dataConRepArity )
+import Coercion ( Coercion, mkUnsafeCoercion, coercionKind )
+import TyCon ( tyConDataCons_maybe, isClosedNewTyCon )
+import DataCon ( DataCon, dataConRepArity, dataConInstArgTys, dataConTyCon )
import VarSet
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
Activation, isAlwaysActive, isActive )
-- (b) This is an argument of a function that has RULES
-- Inlining the call might allow the rule to fire
- | CoerceIt OutType -- The To-type, simplified
+ | CoerceIt OutCoercion -- The coercion simplified
SimplCont
| ApplyTo DupFlag
- InExpr SimplEnv -- The argument, as yet unsimplified,
- SimplCont -- and its environment
+ CoreExpr -- The argument
+ (Maybe SimplEnv) -- (Just se) => the arg is un-simplified and this is its subst-env
+ -- Nothing => the arg is already simplified; don't repeatedly simplify it!
+ SimplCont -- and its environment
| Select DupFlag
InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
- ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
+ ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
data DupFlag = OkToDup | NoDup
ppr NoDup = ptext SLIT("nodup")
+
-------------------
mkBoringStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty AnArg False
discardableCont (CoerceIt _ cont) = discardableCont cont
discardableCont other = True
-discardCont :: SimplCont -- A continuation, expecting
+discardCont :: Type -- The type expected
+ -> SimplCont -- A continuation, expecting the previous type
-> SimplCont -- Replace the continuation with a suitable coerce
-discardCont cont = case cont of
+discardCont from_ty cont = case cont of
Stop to_ty is_rhs _ -> cont
- other -> CoerceIt to_ty (mkBoringStop to_ty)
+ other -> CoerceIt co (mkBoringStop to_ty)
where
- to_ty = contResultType cont
+ co = mkUnsafeCoercion from_ty to_ty
+ to_ty = contResultType cont
-------------------
contResultType :: SimplCont -> OutType
countArgs other = 0
-------------------
-pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
+pushContArgs ::[OutArg] -> SimplCont -> SimplCont
-- Pushes args with the specified environment
-pushContArgs env [] cont = cont
-pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
+pushContArgs [] cont = cont
+pushContArgs (arg : args) cont = ApplyTo NoDup arg Nothing (pushContArgs args cont)
\end{code}
\begin{code}
getContArgs :: SwitchChecker
-> OutId -> SimplCont
- -> ([(InExpr, SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
- SimplCont) -- Remaining continuation
+ -> ([(InExpr, Maybe SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
+ SimplCont) -- Remaining continuation
-- getContArgs id k = (args, k', inl)
-- args are the leading ApplyTo items in k
-- (i.e. outermost comes first)
-- Then, especially in the first of these cases, we'd like to discard
-- the continuation, leaving just the bottoming expression. But the
-- type might not be right, so we may have to add a coerce.
- go acc ss cont
- | null ss && discardableCont cont = (reverse acc, discardCont cont)
- | otherwise = (reverse acc, cont)
+ go acc ss cont
+ | null ss && discardableCont cont = (args, discardCont hole_ty cont)
+ | otherwise = (args, cont)
+ where
+ args = reverse acc
+ hole_ty = applyTypeToArgs (Var fun) (idType fun)
+ [substExpr_mb se arg | (arg,se,_) <- args]
+ substExpr_mb Nothing arg = arg
+ substExpr_mb (Just se) arg = substExpr se arg
+
----------------------------
vanilla_stricts, computed_stricts :: [Bool]
vanilla_stricts = repeat False
computed_stricts = zipWith (||) fun_stricts arg_stricts
----------------------------
- (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun))
+ (val_arg_tys, res_ty) = splitFunTys (dropForAlls (idType fun))
arg_stricts = map isStrictType val_arg_tys ++ repeat False
-- These argument types are used as a cheap and cheerful way to find
-- unboxed arguments, which must be strict. But it's an InType
interestingCallContext some_args some_val_args cont
= interesting cont
where
- interesting (Select _ _ _ _ _) = some_args
- interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
+ interesting (Select {}) = some_args
+ interesting (ApplyTo {}) = True -- Can happen if we have (coerce t (f x)) y
-- Perhaps True is a bit over-keen, but I've
-- seen (coerce f) x, where f has an INLINE prag,
-- So we have to give some motivaiton for inlining it
- interesting (ArgOf _ _ _ _) = some_val_args
+ interesting (ArgOf {}) = some_val_args
interesting (Stop ty _ interesting) = some_val_args && interesting
interesting (CoerceIt _ cont) = interesting cont
-- If this call is the arg of a strict function, the context
-- int_cxt to prevent us inlining inside a lambda without some
-- good reason. See the notes on int_cxt in preInlineUnconditionally
+ IAmDead -> True -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
+ -- create the (dead) let-binding let x = (a,b) in ...
+
other -> False
-- Here's an example that we don't handle well:
%* *
%************************************************************************
+
mkCase puts a case expression back together, trying various transformations first.
\begin{code}
mkCase1 scrut case_bndr ty alts -- Identity case
| all identity_alt alts
= tick (CaseIdentity case_bndr) `thenSmpl_`
- returnSmpl (re_note scrut)
+ returnSmpl (re_cast scrut)
where
- identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
+ identity_alt (con, args, rhs) = de_cast rhs `cheapEqExpr` mk_id_rhs con args
- identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
- identity_rhs (LitAlt lit) _ = Lit lit
- identity_rhs DEFAULT _ = Var case_bndr
+ mk_id_rhs (DataAlt con) args = mkConApp con (arg_tys ++ varsToCoreExprs args)
+ mk_id_rhs (LitAlt lit) _ = Lit lit
+ mk_id_rhs DEFAULT _ = Var case_bndr
arg_tys = map Type (tyConAppArgs (idType case_bndr))
-- We've seen this:
- -- case coerce T e of x { _ -> coerce T' x }
- -- And we definitely want to eliminate this case!
- -- So we throw away notes from the RHS, and reconstruct
- -- (at least an approximation) at the other end
- de_note (Note _ e) = de_note e
- de_note e = e
-
- -- re_note wraps a coerce if it might be necessary
- re_note scrut = case head alts of
- (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
- other -> scrut
+ -- case e of x { _ -> x `cast` c }
+ -- And we definitely want to eliminate this case, to give
+ -- e `cast` c
+ -- So we throw away the cast from the RHS, and reconstruct
+ -- it at the other end. All the RHS casts must be the same
+ -- if (all identity_alt alts) holds.
+ --
+ -- Don't worry about nested casts, because the simplifier combines them
+ de_cast (Cast e _) = e
+ de_cast e = e
+
+ re_cast scrut = case head alts of
+ (_,_,Cast _ co) -> Cast scrut co
+ other -> scrut
+
--------------------------------------------------
projects / ghc-hetmet.git / blobdiff