Commit bb394e57 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Massive patch for the first months work adding System FC to GHC #30

Fri Aug  4 18:13:20 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Massive patch for the first months work adding System FC to GHC #30
  
  Broken up massive patch -=chak
  Original log message:  
  This is (sadly) all done in one patch to avoid Darcs bugs.
  It's not complete work... more FC stuff to come.  A compiler
  using just this patch will fail dismally.
parent 108361d0
......@@ -223,6 +223,7 @@ cseExpr env (Var v) = Var (lookupSubst env v)
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
......
......@@ -139,6 +139,8 @@ fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
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}
......@@ -212,10 +214,6 @@ fiExpr to_drop (_, AnnNote InlineMe expr)
= -- 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}
......
......@@ -315,6 +315,10 @@ floatExpr lvl (Note note expr) -- Other than SCCs
= 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') ->
......
......@@ -455,6 +455,11 @@ occAnal env (Note note body)
= 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}
......
......@@ -290,6 +290,10 @@ lvlExpr ctxt_lvl env (_, AnnNote note expr)
= 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
......
......@@ -7,6 +7,7 @@
module SimplEnv (
InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
InCoercion, OutCoercion,
-- The simplifier mode
setMode, getMode,
......@@ -21,7 +22,7 @@ module SimplEnv (
SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
getRules, refineSimplEnv,
getRules,
SimplSR(..), mkContEx, substId,
......@@ -46,7 +47,6 @@ import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecIn
unknownArity, workerExists
)
import CoreSyn
import Unify ( TypeRefinement )
import Rules ( RuleBase )
import CoreUtils ( needsCaseBinding )
import CostCentre ( CostCentreStack, subsumedCCS )
......@@ -60,6 +60,7 @@ import qualified Type ( substTy, substTyVarBndr )
import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
isUnLiftedType, seqType, tyVarsOfType )
import Coercion ( Coercion )
import BasicTypes ( OccInfo(..), isFragileOcc )
import DynFlags ( SimplifierMode(..) )
import Util ( mapAccumL )
......@@ -73,22 +74,24 @@ import Outputable
%************************************************************************
\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}
%************************************************************************
......@@ -197,38 +200,6 @@ seIdSubst:
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
......@@ -309,31 +280,6 @@ getRules :: SimplEnv -> RuleBase
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}
%************************************************************************
%* *
......@@ -362,8 +308,7 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
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!
......@@ -442,7 +387,7 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
-- 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
......
......@@ -5,7 +5,7 @@
\begin{code}
module SimplUtils (
mkLam, mkCase,
mkLam, mkCase, mkDataConAlt,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
......@@ -31,23 +31,29 @@ import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
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 )
......@@ -75,7 +81,7 @@ data SimplCont -- Strict contexts
-- (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
......@@ -114,7 +120,7 @@ instance Outputable SimplCont where
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
......@@ -123,6 +129,7 @@ instance Outputable DupFlag where
ppr NoDup = ptext SLIT("nodup")
-------------------
mkBoringStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty AnArg False
......@@ -156,13 +163,15 @@ discardableCont (Stop _ _ _) = 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
......@@ -230,17 +239,22 @@ getContArgs chkr fun orig_cont
-- 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
......@@ -1123,6 +1137,28 @@ tryRhsTyLam env tyvars body -- Only does something if there's a let
%* *
%************************************************************************
\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}
......@@ -1449,11 +1485,16 @@ mkCase1 scrut case_bndr ty alts -- Identity case
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 }
......@@ -1465,10 +1506,14 @@ mkCase1 scrut case_bndr ty alts -- Identity case
-- 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
--------------------------------------------------
......
......@@ -13,7 +13,7 @@ import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings),
)
import SimplMonad
import SimplEnv
import SimplUtils ( mkCase, mkLam,
import SimplUtils ( mkCase, mkLam, mkDataConAlt,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkRhsStop, mkBoringStop, mkLazyArgStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg,
......@@ -34,9 +34,8 @@ import IdInfo ( OccInfo(..), isLoopBreaker,
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 )
......@@ -45,15 +44,18 @@ import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
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 )
......@@ -61,8 +63,6 @@ import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRec
)
import Name ( mkSysTvName )
import StaticFlags ( opt_PprStyle_Debug )
import OrdList
import List ( nub )
import Maybes ( orElse )
......@@ -715,7 +715,9 @@ simplExprF env (Var v) cont = simplVar env v cont
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 )
......@@ -761,6 +763,66 @@ simplType env ty
\end{code}
%************************************************************************
%* *
\subsection{Lambdas}
%* *
%************************************************************************
\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}
......@@ -829,56 +891,6 @@ mkLamBndrZapper fun n_args
%************************************************************************
\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
......@@ -1249,7 +1261,7 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
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
......@@ -1536,7 +1548,8 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
-- 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
......@@ -1555,29 +1568,6 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
; 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
......@@ -1612,7 +1602,6 @@ simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
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.
......@@ -1624,50 +1613,11 @@ simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
-- 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