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

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) ...@@ -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 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 evn (Note InlineMe e) = Note InlineMe e -- See Note [INLINE and NOINLINE]
cseExpr env (Note n e) = Note n (cseExpr env e) 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 cseExpr env (Lam b e) = let (env', b') = addBinder env b
in Lam b' (cseExpr env' e) in Lam b' (cseExpr env' e)
cseExpr env (Let bind e) = let (env', bind') = cseBind env bind 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) ...@@ -139,6 +139,8 @@ fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
Type ty 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 fiExpr to_drop (_, AnnLit lit) = Lit lit
\end{code} \end{code}
...@@ -212,10 +214,6 @@ fiExpr to_drop (_, AnnNote InlineMe expr) ...@@ -212,10 +214,6 @@ fiExpr to_drop (_, AnnNote InlineMe expr)
= -- Ditto... don't float anything into an INLINE expression = -- Ditto... don't float anything into an INLINE expression
mkCoLets' to_drop (Note InlineMe (fiExpr [] expr)) 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) fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
= Note note (fiExpr to_drop expr) = Note note (fiExpr to_drop expr)
\end{code} \end{code}
......
...@@ -315,6 +315,10 @@ floatExpr lvl (Note note expr) -- Other than SCCs ...@@ -315,6 +315,10 @@ floatExpr lvl (Note note expr) -- Other than SCCs
= case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
(fs, floating_defns, Note note 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) floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
| isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case
= case floatExpr lvl rhs of { (fs, rhs_floats, rhs') -> = case floatExpr lvl rhs of { (fs, rhs_floats, rhs') ->
......
...@@ -455,6 +455,11 @@ occAnal env (Note note body) ...@@ -455,6 +455,11 @@ occAnal env (Note note body)
= case occAnal env body of { (usage, body') -> = case occAnal env body of { (usage, body') ->
(usage, Note note body') (usage, Note note body')
} }
occAnal env (Cast expr co)
= case occAnal env expr of { (usage, expr') ->
(usage, Cast expr' co)
}
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -290,6 +290,10 @@ lvlExpr ctxt_lvl env (_, AnnNote note expr) ...@@ -290,6 +290,10 @@ lvlExpr ctxt_lvl env (_, AnnNote note expr)
= lvlExpr ctxt_lvl env expr `thenLvl` \ expr' -> = lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
returnLvl (Note note 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 -- We don't split adjacent lambdas. That is, given
-- \x y -> (x+1,y) -- \x y -> (x+1,y)
-- we don't float to give -- we don't float to give
......
...@@ -7,6 +7,7 @@ ...@@ -7,6 +7,7 @@
module SimplEnv ( module SimplEnv (
InId, InBind, InExpr, InAlt, InArg, InType, InBinder, InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
InCoercion, OutCoercion,
-- The simplifier mode -- The simplifier mode
setMode, getMode, setMode, getMode,
...@@ -21,7 +22,7 @@ module SimplEnv ( ...@@ -21,7 +22,7 @@ module SimplEnv (
SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
zapSubstEnv, setSubstEnv, zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
getRules, refineSimplEnv, getRules,
SimplSR(..), mkContEx, substId, SimplSR(..), mkContEx, substId,
...@@ -46,7 +47,6 @@ import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecIn ...@@ -46,7 +47,6 @@ import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecIn
unknownArity, workerExists unknownArity, workerExists
) )
import CoreSyn import CoreSyn
import Unify ( TypeRefinement )
import Rules ( RuleBase ) import Rules ( RuleBase )
import CoreUtils ( needsCaseBinding ) import CoreUtils ( needsCaseBinding )
import CostCentre ( CostCentreStack, subsumedCCS ) import CostCentre ( CostCentreStack, subsumedCCS )
...@@ -60,6 +60,7 @@ import qualified Type ( substTy, substTyVarBndr ) ...@@ -60,6 +60,7 @@ import qualified Type ( substTy, substTyVarBndr )
import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst, import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
isUnLiftedType, seqType, tyVarsOfType ) isUnLiftedType, seqType, tyVarsOfType )
import Coercion ( Coercion )
import BasicTypes ( OccInfo(..), isFragileOcc ) import BasicTypes ( OccInfo(..), isFragileOcc )
import DynFlags ( SimplifierMode(..) ) import DynFlags ( SimplifierMode(..) )
import Util ( mapAccumL ) import Util ( mapAccumL )
...@@ -80,11 +81,13 @@ type InBind = CoreBind ...@@ -80,11 +81,13 @@ type InBind = CoreBind
type InExpr = CoreExpr type InExpr = CoreExpr
type InAlt = CoreAlt type InAlt = CoreAlt
type InArg = CoreArg type InArg = CoreArg
type InCoercion = Coercion
type OutBinder = CoreBndr type OutBinder = CoreBndr
type OutId = Id -- Cloned type OutId = Id -- Cloned
type OutTyVar = TyVar -- Cloned type OutTyVar = TyVar -- Cloned
type OutType = Type -- Cloned type OutType = Type -- Cloned
type OutCoercion = Coercion
type OutBind = CoreBind type OutBind = CoreBind
type OutExpr = CoreExpr type OutExpr = CoreExpr
type OutAlt = CoreAlt type OutAlt = CoreAlt
...@@ -197,38 +200,6 @@ seIdSubst: ...@@ -197,38 +200,6 @@ seIdSubst:
That's why the "set" is actually a VarEnv Var 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} \begin{code}
mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
mkSimplEnv mode switches rules mkSimplEnv mode switches rules
...@@ -309,31 +280,6 @@ getRules :: SimplEnv -> RuleBase ...@@ -309,31 +280,6 @@ getRules :: SimplEnv -> RuleBase
getRules = seExtRules getRules = seExtRules
\end{code} \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 ...@@ -362,8 +308,7 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
where where
-- Get the most up-to-date thing from the in-scope set -- Get the most up-to-date thing from the in-scope set
-- Even though it isn't in the substitution, it may be in -- Even though it isn't in the substitution, it may be in
-- the in-scope set with a different type (we only use the -- the in-scope set better IdInfo
-- substitution if the unique changes).
refine v = case lookupInScope in_scope v of refine v = case lookupInScope in_scope v of
Just v' -> v' Just v' -> v'
Nothing -> WARN( True, ppr v ) v -- This is an error! Nothing -> WARN( True, ppr v ) v -- This is an error!
...@@ -442,7 +387,7 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) ...@@ -442,7 +387,7 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
-- new_id has the final IdInfo -- new_id has the final IdInfo
subst = mkCoreSubst env 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 -- Extend the substitution if the unique has changed
-- See the notes with substTyVarBndr for the delSubstEnv -- See the notes with substTyVarBndr for the delSubstEnv
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
\begin{code} \begin{code}
module SimplUtils ( module SimplUtils (
mkLam, mkCase, mkLam, mkCase, mkDataConAlt,
-- Inlining, -- Inlining,
preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule, preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
...@@ -31,23 +31,29 @@ import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining, ...@@ -31,23 +31,29 @@ import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
import CoreSyn import CoreSyn
import CoreFVs ( exprFreeVars ) import CoreFVs ( exprFreeVars )
import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2, etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts,
applyTypeToArgs
) )
import Literal ( mkStringLit ) import Literal ( mkStringLit )
import CoreUnfold ( smallEnoughToInline ) import CoreUnfold ( smallEnoughToInline )
import MkId ( eRROR_ID ) import MkId ( eRROR_ID, wrapNewTypeBody )
import Id ( Id, idType, isDataConWorkId, idOccInfo, isDictId, import Id ( Id, idType, isDataConWorkId, idOccInfo, isDictId,
isDeadBinder, idNewDemandInfo, isExportedId, isDeadBinder, idNewDemandInfo, isExportedId, mkSysLocal,
idUnfolding, idNewStrictness, idInlinePragma, idHasRules idUnfolding, idNewStrictness, idInlinePragma, idHasRules
) )
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad import SimplMonad
import Var ( tyVarKind, mkTyVar )
import Name ( mkSysTvName )
import Type ( Type, splitFunTys, dropForAlls, isStrictType, import Type ( Type, splitFunTys, dropForAlls, isStrictType,
splitTyConApp_maybe, tyConAppArgs splitTyConApp_maybe, tyConAppArgs, mkTyVarTys )
import Coercion ( isEqPredTy
) )
import TyCon ( tyConDataCons_maybe ) import Coercion ( Coercion, mkUnsafeCoercion, coercionKind )
import DataCon ( dataConRepArity ) import TyCon ( tyConDataCons_maybe, isNewTyCon )
import DataCon ( DataCon, dataConRepArity, dataConExTyVars,
dataConInstArgTys, dataConTyCon )
import VarSet import VarSet
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc, import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
Activation, isAlwaysActive, isActive ) Activation, isAlwaysActive, isActive )
...@@ -75,7 +81,7 @@ data SimplCont -- Strict contexts ...@@ -75,7 +81,7 @@ data SimplCont -- Strict contexts
-- (b) This is an argument of a function that has RULES -- (b) This is an argument of a function that has RULES
-- Inlining the call might allow the rule to fire -- Inlining the call might allow the rule to fire
| CoerceIt OutType -- The To-type, simplified | CoerceIt OutCoercion -- The coercion simplified
SimplCont SimplCont
| ApplyTo DupFlag | ApplyTo DupFlag
...@@ -114,7 +120,7 @@ instance Outputable SimplCont where ...@@ -114,7 +120,7 @@ instance Outputable SimplCont where
ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...") ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont (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 data DupFlag = OkToDup | NoDup
...@@ -123,6 +129,7 @@ instance Outputable DupFlag where ...@@ -123,6 +129,7 @@ instance Outputable DupFlag where
ppr NoDup = ptext SLIT("nodup") ppr NoDup = ptext SLIT("nodup")
------------------- -------------------
mkBoringStop :: OutType -> SimplCont mkBoringStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty AnArg False mkBoringStop ty = Stop ty AnArg False
...@@ -156,12 +163,14 @@ discardableCont (Stop _ _ _) = False ...@@ -156,12 +163,14 @@ discardableCont (Stop _ _ _) = False
discardableCont (CoerceIt _ cont) = discardableCont cont discardableCont (CoerceIt _ cont) = discardableCont cont
discardableCont other = True 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 -> 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 Stop to_ty is_rhs _ -> cont
other -> CoerceIt to_ty (mkBoringStop to_ty) other -> CoerceIt co (mkBoringStop to_ty)
where where
co = mkUnsafeCoercion from_ty to_ty
to_ty = contResultType cont to_ty = contResultType cont
------------------- -------------------
...@@ -230,9 +239,14 @@ getContArgs chkr fun orig_cont ...@@ -230,9 +239,14 @@ getContArgs chkr fun orig_cont
-- Then, especially in the first of these cases, we'd like to discard -- Then, especially in the first of these cases, we'd like to discard
-- the continuation, leaving just the bottoming expression. But the -- the continuation, leaving just the bottoming expression. But the
-- type might not be right, so we may have to add a coerce. -- type might not be right, so we may have to add a coerce.
go acc ss cont go acc ss cont
| null ss && discardableCont cont = (reverse acc, discardCont cont) | null ss && discardableCont cont = (args, discardCont hole_ty cont)
| otherwise = (reverse acc, 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, computed_stricts :: [Bool]
...@@ -240,7 +254,7 @@ getContArgs chkr fun orig_cont ...@@ -240,7 +254,7 @@ getContArgs chkr fun orig_cont
computed_stricts = zipWith (||) fun_stricts arg_stricts 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 arg_stricts = map isStrictType val_arg_tys ++ repeat False
-- These argument types are used as a cheap and cheerful way to find -- These argument types are used as a cheap and cheerful way to find
-- unboxed arguments, which must be strict. But it's an InType -- 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 ...@@ -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. mkCase puts a case expression back together, trying various transformations first.
\begin{code} \begin{code}
...@@ -1449,11 +1485,16 @@ mkCase1 scrut case_bndr ty alts -- Identity case ...@@ -1449,11 +1485,16 @@ mkCase1 scrut case_bndr ty alts -- Identity case
where where
identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args 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 (LitAlt lit) _ = Lit lit
identity_rhs DEFAULT _ = Var case_bndr 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: -- We've seen this:
-- case coerce T e of x { _ -> coerce T' x } -- case coerce T e of x { _ -> coerce T' x }
...@@ -1465,10 +1506,14 @@ mkCase1 scrut case_bndr ty alts -- Identity case ...@@ -1465,10 +1506,14 @@ mkCase1 scrut case_bndr ty alts -- Identity case
-- re_note wraps a coerce if it might be necessary -- re_note wraps a coerce if it might be necessary
re_note scrut = case head alts of 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 other -> scrut
-------------------------------------------------- --------------------------------------------------
-- Catch-all -- Catch-all
-------------------------------------------------- --------------------------------------------------
......
...@@ -13,7 +13,7 @@ import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings), ...@@ -13,7 +13,7 @@ import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings),
) )
import SimplMonad import SimplMonad
import SimplEnv import SimplEnv
import SimplUtils ( mkCase, mkLam, import SimplUtils ( mkCase, mkLam, mkDataConAlt,
SimplCont(..), DupFlag(..), LetRhsFlag(..), SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkRhsStop, mkBoringStop, mkLazyArgStop, pushContArgs, mkRhsStop, mkBoringStop, mkLazyArgStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg, contResultType, countArgs, contIsDupable, contIsRhsOrArg,
...@@ -34,9 +34,8 @@ import IdInfo ( OccInfo(..), isLoopBreaker, ...@@ -34,9 +34,8 @@ import IdInfo ( OccInfo(..), isLoopBreaker,
occInfo occInfo
) )
import NewDemand ( isStrictDmd ) import NewDemand ( isStrictDmd )
import Unify ( coreRefineTys, dataConCanMatch ) import TcGadt ( dataConCanMatch )
import DataCon ( DataCon, dataConTyCon, dataConRepStrictness, isVanillaDataCon, import DataCon ( DataCon, dataConTyCon, dataConRepStrictness )
dataConInstArgTys, dataConTyVars )
import TyCon ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe ) import TyCon ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe )
import CoreSyn import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr ) import PprCore ( pprParendExpr, pprCoreExpr )
...@@ -45,15 +44,18 @@ import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, ...@@ -45,15 +44,18 @@ import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt, exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsHNF, findDefault, mergeAlts, exprType, exprIsHNF, findDefault, mergeAlts,
exprOkForSpeculation, exprArity, exprOkForSpeculation, exprArity,
mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg mkCoerce, mkSCC, mkInlineMe, applyTypeToArg
) )
import Rules ( lookupRule ) import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict ) import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS ) import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy, import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, coreEqType, splitTyConApp_maybe, 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 Var ( tyVarKind, mkTyVar )
import VarEnv ( elemVarEnv, emptyVarEnv ) import VarEnv ( elemVarEnv, emptyVarEnv )
import TysPrim ( realWorldStatePrimTy ) import TysPrim ( realWorldStatePrimTy )
...@@ -61,8 +63,6 @@ import PrelInfo ( realWorldPrimId ) ...@@ -61,8 +63,6 @@ import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel, import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRec RecFlag(..), isNonRec
) )
import Name ( mkSysTvName )
import StaticFlags ( opt_PprStyle_Debug )
import OrdList import OrdList
import List ( nub ) import List ( nub )
import Maybes ( orElse ) import Maybes ( orElse )
...@@ -715,7 +715,9 @@ simplExprF env (Var v) cont = simplVar env v cont ...@@ -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 (Lit lit) cont = rebuild env (Lit lit) cont
simplExprF env expr@(Lam _ _) cont = simplLam env expr cont simplExprF env expr@(Lam _ _) cont = simplLam env expr cont
simplExprF env (Note note expr) cont = simplNote env note 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 simplExprF env (Type ty) cont
= ASSERT( contIsRhsOrArg cont ) = ASSERT( contIsRhsOrArg cont )
...@@ -761,6 +763,66 @@ simplType env ty ...@@ -761,6 +763,66 @@ simplType env ty
\end{code} \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