cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
cseExpr evn (Note InlineMe e) = Note InlineMe e -- See Note [INLINE and NOINLINE]
cseExpr env (Note n e) = Note n (cseExpr env e)
+cseExpr env (Cast e co) = Cast (cseExpr env e) co
cseExpr env (Lam b e) = let (env', b') = addBinder env b
in Lam b' (cseExpr env' e)
cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
Type ty
+fiExpr to_drop (_, AnnCast expr co)
+ = Cast (fiExpr to_drop expr) co -- Just float in past coercion
fiExpr to_drop (_, AnnLit lit) = Lit lit
\end{code}
= -- Ditto... don't float anything into an INLINE expression
mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
-fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
- = -- Just float in past coercion
- Note note (fiExpr to_drop expr)
-
fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
= Note note (fiExpr to_drop expr)
\end{code}
= case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
(fs, floating_defns, Note note expr') }
+floatExpr lvl (Cast expr co)
+ = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
+ (fs, floating_defns, Cast expr' co) }
+
floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
| isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case
= case floatExpr lvl rhs of { (fs, rhs_floats, rhs') ->
= case occAnal env body of { (usage, body') ->
(usage, Note note body')
}
+
+occAnal env (Cast expr co)
+ = case occAnal env expr of { (usage, expr') ->
+ (usage, Cast expr' co)
+ }
\end{code}
\begin{code}
= lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
returnLvl (Note note expr')
+lvlExpr ctxt_lvl env (_, AnnCast expr co)
+ = lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
+ returnLvl (Cast expr' co)
+
-- We don't split adjacent lambdas. That is, given
-- \x y -> (x+1,y)
-- we don't float to give
module SimplEnv (
InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
+ InCoercion, OutCoercion,
-- The simplifier mode
setMode, getMode,
SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
- getRules, refineSimplEnv,
+ getRules,
SimplSR(..), mkContEx, substId,
unknownArity, workerExists
)
import CoreSyn
-import Unify ( TypeRefinement )
import Rules ( RuleBase )
import CoreUtils ( needsCaseBinding )
import CostCentre ( CostCentreStack, subsumedCCS )
import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
isUnLiftedType, seqType, tyVarsOfType )
+import Coercion ( Coercion )
import BasicTypes ( OccInfo(..), isFragileOcc )
import DynFlags ( SimplifierMode(..) )
import Util ( mapAccumL )
%************************************************************************
\begin{code}
-type InBinder = CoreBndr
-type InId = Id -- Not yet cloned
-type InType = Type -- Ditto
-type InBind = CoreBind
-type InExpr = CoreExpr
-type InAlt = CoreAlt
-type InArg = CoreArg
-
-type OutBinder = CoreBndr
-type OutId = Id -- Cloned
-type OutTyVar = TyVar -- Cloned
-type OutType = Type -- Cloned
-type OutBind = CoreBind
-type OutExpr = CoreExpr
-type OutAlt = CoreAlt
-type OutArg = CoreArg
+type InBinder = CoreBndr
+type InId = Id -- Not yet cloned
+type InType = Type -- Ditto
+type InBind = CoreBind
+type InExpr = CoreExpr
+type InAlt = CoreAlt
+type InArg = CoreArg
+type InCoercion = Coercion
+
+type OutBinder = CoreBndr
+type OutId = Id -- Cloned
+type OutTyVar = TyVar -- Cloned
+type OutType = Type -- Cloned
+type OutCoercion = Coercion
+type OutBind = CoreBind
+type OutExpr = CoreExpr
+type OutAlt = CoreAlt
+type OutArg = CoreArg
\end{code}
%************************************************************************
That's why the "set" is actually a VarEnv Var
-Note [GADT type refinement]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we come to a GADT pattern match that refines the in-scope types, we
- a) Refine the types of the Ids in the in-scope set, seInScope.
- For exmaple, consider
- data T a where
- Foo :: T (Bool -> Bool)
-
- (\ (x::T a) (y::a) -> case x of { Foo -> y True }
-
- Technically this is well-typed, but exprType will barf on the
- (y True) unless we refine the type on y's occurrence.
-
- b) Refine the range of the type substitution, seTvSubst.
- Very similar reason to (a).
-
- NB: we don't refine the range of the SimplIdSubst, because it's always
- interpreted relative to the seInScope (see substId)
-
-For (b) we need to be a little careful. Specifically, we compose the refinement
-with the type substitution. Suppose
- The substitution was [a->b, b->a]
- and the refinement was [b->Int]
- Then we want [a->Int, b->a]
-
-But also if
- The substitution was [a->b]
- and the refinement was [b->Int]
- Then we want [a->Int, b->Int]
- becuase b might be both an InTyVar and OutTyVar
-
-
\begin{code}
mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
mkSimplEnv mode switches rules
getRules = seExtRules
\end{code}
- GADT stuff
-
-Given an idempotent substitution, generated by the unifier, use it to
-refine the environment
-
-\begin{code}
-refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv
--- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
-refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
- (refine_tv_subst, all_bound_here)
- = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
- seInScope = in_scope' }
- where
- in_scope'
- | all_bound_here = in_scope
- -- The tvs are the tyvars bound here. If only they
- -- are refined, there's no need to do anything
- | otherwise = mapInScopeSet refine_id in_scope
-
- refine_id v -- Only refine its type; any rules will get
- -- refined if they are used (I hope)
- | isId v = setIdType v (Type.substTy refine_subst (idType v))
- | otherwise = v
- refine_subst = TvSubst in_scope refine_tv_subst
-\end{code}
%************************************************************************
%* *
where
-- Get the most up-to-date thing from the in-scope set
-- Even though it isn't in the substitution, it may be in
- -- the in-scope set with a different type (we only use the
- -- substitution if the unique changes).
+ -- the in-scope set better IdInfo
refine v = case lookupInScope in_scope v of
Just v' -> v'
Nothing -> WARN( True, ppr v ) v -- This is an error!
-- new_id has the final IdInfo
subst = mkCoreSubst env
- new_id = maybeModifyIdInfo (substIdInfo subst) id2
+ new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
-- Extend the substitution if the unique has changed
-- See the notes with substTyVarBndr for the delSubstEnv
\begin{code}
module SimplUtils (
- mkLam, mkCase,
+ mkLam, mkCase, mkDataConAlt,
-- 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, isNewTyCon )
+import DataCon ( DataCon, dataConRepArity, dataConExTyVars,
+ 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
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
-- 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 se arg | (arg,se,_) <- args]
+
----------------------------
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
%* *
%************************************************************************
+\begin{code}
+mkDataConAlt :: DataCon -> [OutType] -> InExpr -> SimplM InAlt
+-- Make a data-constructor alternative to replace the DEFAULT case
+-- NB: there's something a bit bogus here, because we put OutTypes into an InAlt
+mkDataConAlt con inst_tys rhs
+ = do { tv_uniqs <- getUniquesSmpl
+ ; arg_uniqs <- getUniquesSmpl
+ ; let tv_bndrs = zipWith mk_tv_bndr (dataConExTyVars con) tv_uniqs
+ arg_tys = dataConInstArgTys con (inst_tys ++ mkTyVarTys tv_bndrs)
+ arg_bndrs = zipWith mk_arg arg_tys arg_uniqs
+ ; return (DataAlt con, tv_bndrs ++ arg_bndrs, rhs) }
+ where
+ mk_arg arg_ty uniq -- Equality predicates get a TyVar
+ -- while dictionaries and others get an Id
+ | isEqPredTy arg_ty = mk_tv arg_ty uniq
+ | otherwise = mk_id arg_ty uniq
+
+ mk_tv_bndr tv uniq = mk_tv (tyVarKind tv) uniq
+ mk_tv kind uniq = mkTyVar (mkSysTvName uniq FSLIT("t")) kind
+ mk_id ty uniq = mkSysLocal FSLIT("a") uniq ty
+\end{code}
+
mkCase puts a case expression back together, trying various transformations first.
\begin{code}
where
identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
- identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
+ identity_rhs (DataAlt con) args
+ | isNewTyCon (dataConTyCon con)
+ = wrapNewTypeBody (dataConTyCon con) arg_tys (varToCoreExpr $ head args)
+ | otherwise
+ = pprTrace "mkCase1" (ppr con) $ mkConApp con (arg_ty_exprs ++ varsToCoreExprs args)
identity_rhs (LitAlt lit) _ = Lit lit
identity_rhs DEFAULT _ = Var case_bndr
- arg_tys = map Type (tyConAppArgs (idType case_bndr))
+ arg_tys = (tyConAppArgs (idType case_bndr))
+ arg_ty_exprs = map Type arg_tys
-- We've seen this:
-- case coerce T e of x { _ -> coerce T' x }
-- 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
+ (_,_,rhs1@(Note _ _)) ->
+ let co = mkUnsafeCoercion (idType case_bndr) (exprType rhs1) in
+ -- this unsafeCoercion is bad, make this better
+ mkCoerce co scrut
other -> scrut
+
--------------------------------------------------
-- Catch-all
--------------------------------------------------
)
import SimplMonad
import SimplEnv
-import SimplUtils ( mkCase, mkLam,
+import SimplUtils ( mkCase, mkLam, mkDataConAlt,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkRhsStop, mkBoringStop, mkLazyArgStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg,
occInfo
)
import NewDemand ( isStrictDmd )
-import Unify ( coreRefineTys, dataConCanMatch )
-import DataCon ( DataCon, dataConTyCon, dataConRepStrictness, isVanillaDataCon,
- dataConInstArgTys, dataConTyVars )
+import TcGadt ( dataConCanMatch )
+import DataCon ( DataCon, dataConTyCon, dataConRepStrictness )
import TyCon ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsHNF, findDefault, mergeAlts,
exprOkForSpeculation, exprArity,
- mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
+ mkCoerce, mkSCC, mkInlineMe, applyTypeToArg
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, coreEqType, splitTyConApp_maybe,
- isTyVarTy, mkTyVarTys
+ isTyVarTy, mkTyVarTys, isFunTy, tcEqType
)
+import Coercion ( Coercion, coercionKind,
+ mkTransCoercion, mkLeftCoercion, mkRightCoercion,
+ mkSymCoercion, splitCoercionKind_maybe, decomposeCo )
import Var ( tyVarKind, mkTyVar )
import VarEnv ( elemVarEnv, emptyVarEnv )
import TysPrim ( realWorldStatePrimTy )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRec
)
-import Name ( mkSysTvName )
-import StaticFlags ( opt_PprStyle_Debug )
import OrdList
import List ( nub )
import Maybes ( orElse )
simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont
simplExprF env expr@(Lam _ _) cont = simplLam env expr cont
simplExprF env (Note note expr) cont = simplNote env note expr cont
-simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg (Just env) cont)
+simplExprF env (Cast body co) cont = simplCast env body co cont
+simplExprF env (App fun arg) cont = simplExprF env fun
+ (ApplyTo NoDup arg (Just env) cont)
simplExprF env (Type ty) cont
= ASSERT( contIsRhsOrArg cont )
%************************************************************************
\begin{code}
+simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont -> SimplM FloatsWithExpr
+simplCast env body co cont
+ = let
+ addCoerce co cont
+ | (s1, k1) <- coercionKind co
+ , s1 `tcEqType` k1 = cont
+ addCoerce co1 (CoerceIt co2 cont)
+ | (s1, k1) <- coercionKind co1
+ , (l1, t1) <- coercionKind co2
+ -- coerce T1 S1 (coerce S1 K1 e)
+ -- ==>
+ -- e, if T1=K1
+ -- coerce T1 K1 e, otherwise
+ --
+ -- For example, in the initial form of a worker
+ -- we may find (coerce T (coerce S (\x.e))) y
+ -- and we'd like it to simplify to e[y/x] in one round
+ -- of simplification
+ , s1 `coreEqType` t1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
+
+ addCoerce co (ApplyTo dup arg arg_se cont)
+ | not (isTypeArg arg) -- This whole case only works for value args
+ -- Could upgrade to have equiv thing for type apps too
+ , Just (s1s2, t1t2) <- splitCoercionKind_maybe co
+ , isFunTy s1s2
+ -- co : s1s2 :=: t1t2
+ -- (coerce (T1->T2) (S1->S2) F) E
+ -- ===>
+ -- coerce T2 S2 (F (coerce S1 T1 E))
+ --
+ -- 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
+ -- with the InExpr in the argument, so we simply substitute
+ -- to make it all consistent. It's a bit messy.
+ -- But it isn't a common case.
+ = result
+ 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
+ [co1, co2] = decomposeCo 2 co
+ new_arg = mkCoerce (mkSymCoercion co1) (substExpr arg_env arg)
+ arg_env = setInScope arg_se env
+ result = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
+ addCoerce co cont = CoerceIt co cont
+ in
+ simplType env co `thenSmpl` \ co' ->
+ simplExprF env body (addCoerce co' cont)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Lambdas}
+%* *
+%************************************************************************
+
+\begin{code}
simplLam env fun cont
= go env fun cont
where
%************************************************************************
\begin{code}
-simplNote env (Coerce to from) body cont
- = let
- addCoerce s1 k1 cont -- Drop redundant coerces. This can happen if a polymoprhic
- -- (coerce a b e) is instantiated with a=ty1 b=ty2 and the
- -- two are the same. This happens a lot in Happy-generated parsers
- | s1 `coreEqType` k1 = cont
-
- addCoerce s1 k1 (CoerceIt t1 cont)
- -- coerce T1 S1 (coerce S1 K1 e)
- -- ==>
- -- e, if T1=K1
- -- coerce T1 K1 e, otherwise
- --
- -- For example, in the initial form of a worker
- -- we may find (coerce T (coerce S (\x.e))) y
- -- and we'd like it to simplify to e[y/x] in one round
- -- of simplification
- | t1 `coreEqType` k1 = cont -- The coerces cancel out
- | otherwise = CoerceIt t1 cont -- They don't cancel, but
- -- the inner one is redundant
-
- addCoerce t1t2 s1s2 (ApplyTo dup arg mb_arg_se cont)
- | not (isTypeArg arg), -- This whole case only works for value args
- -- Could upgrade to have equiv thing for type apps too
- Just (s1, s2) <- splitFunTy_maybe s1s2
- -- (coerce (T1->T2) (S1->S2) F) E
- -- ===>
- -- coerce T2 S2 (F (coerce S1 T1 E))
- --
- -- 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
- -- with the InExpr in the argument, so we simply substitute
- -- to make it all consistent. It's a bit messy.
- -- But it isn't a common case.
- = let
- (t1,t2) = splitFunTy t1t2
- new_arg = mkCoerce2 s1 t1 arg'
- arg' = case mb_arg_se of
- Nothing -> arg
- Just arg_se -> substExpr (setInScope arg_se env) arg
- in
- ApplyTo dup new_arg Nothing (addCoerce t2 s2 cont)
-
- addCoerce to' _ cont = CoerceIt to' cont
- in
- simplType env to `thenSmpl` \ to' ->
- simplType env from `thenSmpl` \ from' ->
- simplExprF env body (addCoerce to' from' cont)
-- Hack: we only distinguish subsumed cost centre stacks for the purposes of
rebuild env expr (Stop _ _ _) = rebuildDone env expr
rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
-rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty expr) cont
+rebuild env expr (CoerceIt co cont) = rebuild env (mkCoerce co expr) cont
rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
rebuild env expr (ApplyTo _ arg mb_se cont) = rebuildApp env expr arg mb_se cont
-- altogether if it can't match
[con] -> -- It matches exactly one constructor, so fill it in
- do { con_alt <- mkDataConAlt case_bndr' con inst_tys rhs
+ do { tick (FillInCaseDefault case_bndr')
+ ; con_alt <- mkDataConAlt con inst_tys rhs
; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
-- The simplAlt must succeed with Just because we have
-- already filtered out construtors that can't match
; rhs' <- simplExprC env' rhs cont
; return [(DEFAULT, [], rhs')] }
-mkDataConAlt :: Id -> DataCon -> [OutType] -> InExpr -> SimplM InAlt
--- Make a data-constructor alternative to replace the DEFAULT case
--- NB: there's something a bit bogus here, because we put OutTypes into an InAlt
-mkDataConAlt case_bndr con tys rhs
- = do { tick (FillInCaseDefault case_bndr)
- ; args <- mk_args con tys
- ; return (DataAlt con, args, rhs) }
- where
- mk_args con inst_tys
- = do { (tv_bndrs, inst_tys') <- mk_tv_bndrs con inst_tys
- ; let arg_tys = dataConInstArgTys con inst_tys'
- ; arg_ids <- mapM (newId FSLIT("a")) arg_tys
- ; returnSmpl (tv_bndrs ++ arg_ids) }
-
- mk_tv_bndrs con inst_tys
- | isVanillaDataCon con
- = return ([], inst_tys)
- | otherwise
- = do { tv_uniqs <- getUniquesSmpl
- ; let new_tvs = zipWith mk tv_uniqs (dataConTyVars con)
- mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
- ; return (new_tvs, mkTyVarTys new_tvs) }
-
simplAlt :: SimplEnv
-> [AltCon] -- These constructors can't be present when
-- matching this alternative
env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit))
simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
- | isVanillaDataCon con
= -- Deal with the pattern-bound variables
-- Mark the ones that are in ! positions in the data constructor
-- as certainly-evaluated.
-- Bind the case-binder to (con args)
let unf = mkUnfolding False (mkConApp con con_args)
inst_tys' = tyConAppArgs (idType case_bndr')
- con_args = map Type inst_tys' ++ map varToCoreExpr vs'
+ con_args = map Type inst_tys' ++ varsToCoreExprs vs'
env' = mk_rhs_env env case_bndr' unf
in
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs')))
-
- | otherwise -- GADT case
- = let
- (tvs,ids) = span isTyVar vs
- in
- simplBinders env tvs `thenSmpl` \ (env1, tvs') ->
- case coreRefineTys con tvs' (idType case_bndr') of {
- Nothing -- Inaccessible
- | opt_PprStyle_Debug -- Hack: if debugging is on, generate an error case
- -- so we can see it
- -> let rhs' = mkApps (Var eRROR_ID)
- [Type (substTy env (exprType rhs)),
- Lit (mkStringLit "Impossible alternative (GADT)")]
- in
- simplBinders env1 ids `thenSmpl` \ (env2, ids') ->
- returnSmpl (Just (emptyVarEnv, (DataAlt con, tvs' ++ ids', rhs')))
-
- | otherwise -- Filter out the inaccessible branch
- -> return Nothing ;
-
- Just refine@(tv_subst_env, _) -> -- The normal case
-
- let
- env2 = refineSimplEnv env1 refine
- -- Simplify the Ids in the refined environment, so their types
- -- reflect the refinement. Usually this doesn't matter, but it helps
- -- in mkDupableAlt, when we want to float a lambda that uses these binders
- -- Furthermore, it means the binders contain maximal type information
- in
- simplBinders env2 (add_evals con ids) `thenSmpl` \ (env3, ids') ->
- let unf = mkUnfolding False con_app
- con_app = mkConApp con con_args
- con_args = map varToCoreExpr vs' -- NB: no inst_tys'
- env_w_unf = mk_rhs_env env3 case_bndr' unf
- vs' = tvs' ++ ids'
- in
- simplExprC env_w_unf rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (Just (tv_subst_env, (DataAlt con, vs', rhs'))) }
-
where
-- add_evals records the evaluated-ness of the bound variables of
-- a case pattern. This is *important*. Consider
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
+ n_drop_tys = tyConArity (dataConTyCon dc)
-- Ugh!
bind_args env dead_bndr [] _ thing_inside = thing_inside env
then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
- returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
+ returnSmpl (used_bndrs', varsToCoreExprs used_bndrs')
) `thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
projects / ghc-hetmet.git / commitdiff