Commit f25b9225 authored by simonpj's avatar simonpj
Browse files

[project @ 2005-01-31 13:25:33 by simonpj]

---------------------------
	Types and evaluated-ness in
	  CoreTidy and CorePrep
	---------------------------

This commmit fixes two problems.

1.  DataToTagOp requires its argument to be evaluated, otherwise it silently
    gives the wrong answer.  This was not happening because we had
	case (tag2Enum x) of y -> ...(dataToTag y)...
    and the tag2Enum was being inlined (it's non-speculative), giving
	...(dataToTag (tag2Enum x))...

    Rather than relying on a somewhat-delicate global invariant, CorePrep
    now establishes the invariant that DataToTagOp's argument is evaluated.
    It does so by putting up-to-date is-evaluated information into each
    binder's UnfoldingInfo; not a full unfolding, just the (OtherCon [])
    for evaluated binders.

    Then there's a special case for DataToTag where applications are dealt with.

    Finally, we make DataToTagOp strict, which it really is.


2.  CoreTidy now does GADT refinement as it goes. This is important to ensure that
    each variable occurrence has informative type information, which in turn is
    essential to make exprType work (otherwise it can simply crash).
    [This happened in test gadt/tdpe]

    CorePrep has the same problem, but the solution is a little different:
    when looking up in the cloning environment, use the type at the occurrence
    site if we're inside a GADT.  It might be cleaner to use the same story as
    CoreTidy, but then we'd need to keep an in-scope set for type variables.
    No big deal either way.
parent 04612d54
......@@ -18,7 +18,7 @@ import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
import Unify ( coreRefineTys )
import Bag
import Literal ( literalType )
import DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon, dataConResTy, dataConWorkId )
import DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon, dataConWorkId )
import TysWiredIn ( tupleCon )
import Var ( Var, Id, TyVar, idType, tyVarKind, mustHaveLocalBinding )
import VarSet
......@@ -462,14 +462,12 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
else -- GADT
do { let (tvs,ids) = span isTyVar args
pat_res_ty = dataConResTy con (mkTyVarTys tvs)
; subst <- getTvSubst
; let in_scope = getTvInScope subst
subst_env = getTvSubstEnv subst
; case coreRefineTys in_scope tvs pat_res_ty scrut_ty of {
Nothing -> return () ; -- Alternative is dead code
Just refine -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
; case coreRefineTys in_scope con tvs scrut_ty of {
Nothing -> return () ; -- Alternative is dead code
Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
do { tvs' <- mapM lintTy (mkTyVarTys tvs)
; con_type <- lintTyApps (dataConRepType con) tvs'
; mapM lintBinder ids -- Lint Ids in the refined world
......
......@@ -20,11 +20,13 @@ import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType,
isFCallId, isGlobalId, isImplicitId,
isLocalId, hasNoBinding, idNewStrictness,
idUnfolding, isDataConWorkId_maybe
idUnfolding, isDataConWorkId_maybe, isPrimOpId_maybe
)
import DataCon ( isVanillaDataCon )
import PrimOp ( PrimOp( DataToTagOp ) )
import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
......@@ -118,7 +120,7 @@ corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
corePrepExpr dflags expr
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
(ppr new_expr)
return new_expr
......@@ -224,8 +226,6 @@ instance Outputable FloatingBind where
ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
type CloneEnv = IdEnv Id -- Clone local Ids
deFloatTop :: Floats -> [CoreBind]
-- For top level only; we don't expect any FloatCases
deFloatTop (Floats _ floats)
......@@ -237,7 +237,7 @@ deFloatTop (Floats _ floats)
allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
allLazy top_lvl is_rec (Floats ok_to_spec _)
= case ok_to_spec of
OkToSpec -> True
OkToSpec -> True
NotOkToSpec -> False
IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
......@@ -247,7 +247,7 @@ allLazy top_lvl is_rec (Floats ok_to_spec _)
corePrepTopBinds :: [CoreBind] -> UniqSM Floats
corePrepTopBinds binds
= go emptyVarEnv binds
= go emptyCorePrepEnv binds
where
go env [] = returnUs emptyFloats
go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
......@@ -282,7 +282,7 @@ corePrepTopBinds binds
-- it looks difficult.
--------------------------------
corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats)
corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
corePrepTopBind env (NonRec bndr rhs)
= cloneBndr env bndr `thenUs` \ (env', bndr') ->
corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
......@@ -291,21 +291,23 @@ corePrepTopBind env (NonRec bndr rhs)
corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
--------------------------------
corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats)
corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
-- This one is used for *local* bindings
corePrepBind env (NonRec bndr rhs)
= etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
returnUs (env', floats')
cloneBndr env bndr `thenUs` \ (_, bndr') ->
mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') ->
-- We want bndr'' in the envt, because it records
-- the evaluated-ness of the binder
returnUs (extendCorePrepEnv env bndr bndr'', floats')
corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
--------------------------------
corePrepRecPairs :: TopLevelFlag -> CloneEnv
corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
-> [(Id,CoreExpr)] -- Recursive bindings
-> UniqSM (CloneEnv, Floats)
-> UniqSM (CorePrepEnv, Floats)
-- Used for all recursive bindings, top level and otherwise
corePrepRecPairs lvl env pairs
= cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
......@@ -321,7 +323,7 @@ corePrepRecPairs lvl env pairs
--------------------------------
corePrepRhs :: TopLevelFlag -> RecFlag
-> CloneEnv -> (Id, CoreExpr)
-> CorePrepEnv -> (Id, CoreExpr)
-> UniqSM (Floats, CoreExpr)
-- Used for top-level bindings, and local recursive bindings
corePrepRhs top_lvl is_rec env (bndr, rhs)
......@@ -335,15 +337,15 @@ corePrepRhs top_lvl is_rec env (bndr, rhs)
-- ---------------------------------------------------------------------------
-- This is where we arrange that a non-trivial argument is let-bound
corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
-> UniqSM (Floats, CoreArg)
corePrepArg env arg dem
= corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
if exprIsTrivial arg'
then returnUs (floats, arg')
else newVar (exprType arg') `thenUs` \ v ->
mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
returnUs (floats', Var v)
mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') ->
returnUs (floats', Var v')
-- version that doesn't consider an scc annotation to be trivial.
exprIsTrivial (Var v) = True
......@@ -359,13 +361,13 @@ exprIsTrivial other = False
-- Dealing with expressions
-- ---------------------------------------------------------------------------
corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
corePrepAnExpr env expr
= corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
mkBinds floats expr
corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
-- If
-- e ===> (bs, e')
-- then
......@@ -376,9 +378,10 @@ corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
corePrepExprFloat env (Var v)
= fiddleCCall v `thenUs` \ v1 ->
let v2 = lookupVarEnv env v1 `orElse` v1 in
maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
returnUs (emptyFloats, app)
let
v2 = lookupCorePrepEnv env v1
in
maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
corePrepExprFloat env expr@(Type _)
= returnUs (emptyFloats, expr)
......@@ -410,13 +413,20 @@ corePrepExprFloat env expr@(Lam _ _)
corePrepExprFloat env (Case scrut bndr ty alts)
= corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
let
bndr1 = bndr `setIdUnfolding` evaldUnfolding
-- Record that the case binder is evaluated in the alternatives
in
cloneBndr env bndr1 `thenUs` \ (env', bndr2) ->
mapUs (sat_alt env') alts `thenUs` \ alts' ->
returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' ty alts')
returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
where
sat_alt env (con, bs, rhs)
= cloneBndrs env bs `thenUs` \ (env', bs') ->
corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
= let
env1 = setGadt env con
in
cloneBndrs env1 bs `thenUs` \ (env2, bs') ->
corePrepAnExpr env2 rhs `thenUs` \ rhs1 ->
deLam rhs1 `thenUs` \ rhs2 ->
returnUs (con, bs', rhs2)
......@@ -426,9 +436,7 @@ corePrepExprFloat env expr@(App _ _)
-- Now deal with the function
case head of
Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
returnUs (floats, app')
Var fn_id -> maybeSaturate fn_id app depth floats ty
_other -> returnUs (floats, app)
where
......@@ -467,7 +475,9 @@ corePrepExprFloat env expr@(App _ _)
collect_args (Var v) depth
= fiddleCCall v `thenUs` \ v1 ->
let v2 = lookupVarEnv env v1 `orElse` v1 in
let
v2 = lookupCorePrepEnv env v1
in
returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
where
stricts = case idNewStrictness v of
......@@ -491,14 +501,14 @@ corePrepExprFloat env expr@(App _ _)
= collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
returnUs (Note note fun', hd, fun_ty, floats, ss)
-- non-variable fun, better let-bind it
-- N-variable fun, better let-bind it
-- ToDo: perhaps we can case-bind rather than let-bind this closure,
-- since it is sure to be evaluated.
collect_args fun depth
= corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
newVar ty `thenUs` \ fn_id ->
mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') ->
returnUs (Var fn_id', (Var fn_id', depth), ty, floats, [])
where
ty = exprType fun
......@@ -514,15 +524,32 @@ corePrepExprFloat env expr@(App _ _)
-- maybeSaturate deals with saturating primops and constructors
-- The type is the type of the entire application
maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
maybeSaturate fn expr n_args ty
maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
maybeSaturate fn expr n_args floats ty
| hasNoBinding fn = saturate_it
| otherwise = returnUs expr
| otherwise = returnUs (floats, expr)
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
saturate_it = getUniquesUs `thenUs` \ us ->
returnUs (etaExpand excess_arity us expr ty)
saturate_it = getUniquesUs `thenUs` \ us ->
let expr' = etaExpand excess_arity us expr ty in
case isPrimOpId_maybe fn of
Just DataToTagOp -> hack_data2tag expr'
other -> returnUs (floats, expr')
-- Ensure that the argument of DataToTagOp is evaluated
hack_data2tag app@(Var _fn `App` _ty `App` Var arg_id)
| isEvaldUnfolding (idUnfolding arg_id) -- Includes nullary constructors
= returnUs (floats, app) -- The arg is evaluated
hack_data2tag app@(Var fn `App` Type ty `App` arg)
| otherwise -- Arg not evaluated, so evaluate it
= newVar ty `thenUs` \ arg_id1 ->
let arg_id2 = setIdUnfolding arg_id1 evaldUnfolding
new_float = FloatCase arg_id2 arg False
in
returnUs (addFloat floats new_float,
Var fn `App` Type ty `App` Var arg_id2)
-- ---------------------------------------------------------------------------
-- Precipitating the floating bindings
......@@ -541,8 +568,6 @@ floatRhs top_lvl is_rec bndr (floats, rhs)
-- v = f (x `divInt#` y)
-- we don't want to float the case, even if f has arity 2,
-- because floating the case would make it evaluated too early
--
-- Finally, eta-expand the RHS, for the benefit of the code gen
returnUs (floats, rhs)
| otherwise
......@@ -553,7 +578,8 @@ floatRhs top_lvl is_rec bndr (floats, rhs)
-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
-> Floats -> CoreExpr -- Rhs: let binds in body
-> UniqSM Floats
-> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
-- to record that it's been evaluated
mkLocalNonRec bndr dem floats rhs
| isUnLiftedType (idType bndr)
......@@ -562,7 +588,7 @@ mkLocalNonRec bndr dem floats rhs
let
float = FloatCase bndr rhs (exprOkForSpeculation rhs)
in
returnUs (addFloat floats float)
returnUs (addFloat floats float, evald_bndr)
| isStrict dem
-- It's a strict let so we definitely float all the bindings
......@@ -572,11 +598,16 @@ mkLocalNonRec bndr dem floats rhs
float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
| otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
in
returnUs (addFloat floats float)
returnUs (addFloat floats float, evald_bndr)
| otherwise
= floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')))
returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
if exprIsValue rhs' then evald_bndr else bndr)
where
evald_bndr = bndr `setIdUnfolding` evaldUnfolding
-- Record if the binder is evaluated
mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
......@@ -733,21 +764,59 @@ onceDem = RhsDemand False True -- used at most once
%************************************************************************
\begin{code}
-- ---------------------------------------------------------------------------
-- The environment
-- ---------------------------------------------------------------------------
data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
Bool -- True <=> inside a GADT case; see Note [GADT]
-- Note [GADT]
--
-- Be careful with cloning inside GADTs. For example,
-- /\a. \f::a. \x::T a. case x of { T -> f True; ... }
-- The case on x may refine the type of f to be a function type.
-- Without this type refinement, exprType (f True) may simply fail,
-- which is bad.
--
-- Solution: remember when we are inside a potentially-type-refining case,
-- and in that situation use the type from the old occurrence
-- when looking up occurrences
emptyCorePrepEnv :: CorePrepEnv
emptyCorePrepEnv = CPE emptyVarEnv False
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv (CPE env gadt) id id' = CPE (extendVarEnv env id id') gadt
lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
-- See Note [GADT] above
lookupCorePrepEnv (CPE env gadt) id
= case lookupVarEnv env id of
Nothing -> id
Just id' | gadt -> setIdType id' (idType id)
| otherwise -> id'
setGadt :: CorePrepEnv -> AltCon -> CorePrepEnv
setGadt env@(CPE id_env _) (DataAlt data_con) | not (isVanillaDataCon data_con) = CPE id_env True
setGadt env other = env
------------------------------------------------------------------------------
-- Cloning binders
-- ---------------------------------------------------------------------------
cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
cloneBndrs env bs = mapAccumLUs cloneBndr env bs
cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
cloneBndr env bndr
| isLocalId bndr
= getUniqueUs `thenUs` \ uniq ->
let
bndr' = setVarUnique bndr uniq
in
returnUs (extendVarEnv env bndr bndr', bndr')
returnUs (extendCorePrepEnv env bndr bndr', bndr')
| otherwise -- Top level things, which we don't want
-- to clone, have become GlobalIds by now
......
......@@ -17,14 +17,16 @@ module CoreTidy (
import CoreSyn
import CoreUtils ( exprArity )
import Unify ( coreRefineTys )
import PprCore ( pprIdRules )
import DataCon ( DataCon, isVanillaDataCon )
import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
idType, idCoreRules )
idType, setIdType, idCoreRules )
import IdInfo ( setArityInfo, vanillaIdInfo,
newStrictnessInfo, setAllStrictnessInfo,
newDemandInfo, setNewDemandInfo )
import Type ( tidyType, tidyTyVarBndr )
import Var ( Var )
import Type ( Type, tidyType, tidyTyVarBndr, substTy, mkTvSubst )
import Var ( Var, TyVar )
import VarEnv
import Name ( getOccName )
import OccName ( tidyOccName )
......@@ -73,17 +75,50 @@ tidyExpr env (Let b e)
tidyExpr env (Case e b ty alts)
= tidyBndr env b =: \ (env', b) ->
Case (tidyExpr env e) b (tidyType env ty) (map (tidyAlt env') alts)
Case (tidyExpr env e) b (tidyType env ty)
(map (tidyAlt b env') alts)
tidyExpr env (Lam b e)
= tidyBndr env b =: \ (env', b) ->
Lam b (tidyExpr env' e)
------------ Case alternatives --------------
tidyAlt env (con, vs, rhs)
tidyAlt case_bndr env (DataAlt con, vs, rhs)
| not (isVanillaDataCon con) -- GADT case
= tidyBndrs env tvs =: \ (env1, tvs') ->
let
env2 = refineTidyEnv env con tvs' scrut_ty
in
tidyBndrs env2 ids =: \ (env3, ids') ->
(DataAlt con, tvs' ++ ids', tidyExpr env3 rhs)
where
(tvs, ids) = span isTyVar vs
scrut_ty = idType case_bndr
tidyAlt case_bndr env (con, vs, rhs)
= tidyBndrs env vs =: \ (env', vs) ->
(con, vs, tidyExpr env' rhs)
refineTidyEnv :: TidyEnv -> DataCon -> [TyVar] -> Type -> TidyEnv
-- Refine the TidyEnv in the light of the type refinement from coreRefineTys
refineTidyEnv tidy_env@(occ_env, var_env) con tvs scrut_ty
= case coreRefineTys in_scope con tvs scrut_ty of
Nothing -> tidy_env
Just (tv_subst, all_bound_here)
| all_bound_here -- Local type refinement only
-> tidy_env
| otherwise -- Apply the refining subst to the tidy env
-- This ensures that occurences have the most refined type
-- And that means that exprType will work right everywhere
-> (occ_env, mapVarEnv (refine subst) var_env)
where
subst = mkTvSubst in_scope tv_subst
where
refine subst var | isId var = setIdType var (substTy subst (idType var))
| otherwise = var
in_scope = mkInScopeSet var_env -- Seldom used
------------ Notes --------------
tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
tidyNote env note = note
......
-----------------------------------------------------------------------
-- $Id: primops.txt.pp,v 1.31 2004/11/18 09:56:15 tharris Exp $
-- $Id: primops.txt.pp,v 1.32 2005/01/31 13:25:38 simonpj Exp $
--
-- Primitive Operations
--
......@@ -1714,6 +1714,9 @@ section "Tag to enum stuff"
primop DataToTagOp "dataToTag#" GenPrimOp
a -> Int#
with
strictness = { \ arity -> mkStrictSig (mkTopDmdType [seqDmd] TopRes) }
-- dataToTag# must have an evaluated argument
primop TagToEnumOp "tagToEnum#" GenPrimOp
Int# -> a
......
......@@ -46,6 +46,7 @@ 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 )
......@@ -308,22 +309,19 @@ Given an idempotent substitution, generated by the unifier, use it to
refine the environment
\begin{code}
refineSimplEnv :: SimplEnv -> TvSubstEnv -> [OutTyVar] -> SimplEnv
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 tvs
(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 (varEnvKeys refine_tv_subst) = 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
bound_here uniq = elemVarSetByKey uniq tv_set
tv_set = mkVarSet tvs
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))
......
......@@ -36,11 +36,11 @@ import IdInfo ( OccInfo(..), isLoopBreaker,
)
import NewDemand ( isStrictDmd )
import Unify ( coreRefineTys )
import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon, dataConResTy )
import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon )
import TyCon ( tyConArity )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline )
import CoreUnfold ( mkOtherCon, mkUnfolding, evaldUnfolding, callSiteInline )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsValue,
......@@ -51,7 +51,7 @@ import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, coreEqType, mkTyVarTys
splitFunTy_maybe, splitFunTy, coreEqType
)
import VarEnv ( elemVarEnv )
import TysPrim ( realWorldStatePrimTy )
......@@ -1498,11 +1498,7 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont'
(tvs,ids) = span isTyVar vs
in
simplBinders env tvs `thenSmpl` \ (env1, tvs') ->
let
pat_res_ty = dataConResTy con (mkTyVarTys tvs')
in_scope = getInScope env1
in
case coreRefineTys in_scope tvs' pat_res_ty (idType case_bndr') of {
case coreRefineTys (getInScope env1) con tvs' (idType case_bndr') of {
Nothing -- Dead code; for now, I'm just going to put in an
-- error case so I can see them
-> let rhs' = mkApps (Var eRROR_ID)
......@@ -1512,13 +1508,14 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont'
simplBinders env1 ids `thenSmpl` \ (env2, ids') ->
returnSmpl (Nothing, (DataAlt con, tvs' ++ ids', rhs')) ;
Just tv_subst_env -> -- The normal case
Just refine@(tv_subst_env, _) -> -- The normal case
let
env2 = refineSimplEnv env1 tv_subst_env tvs'
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
......@@ -1551,7 +1548,7 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont'
| otherwise = zapped_v : go vs strs
where
zapped_v = zap_occ_info v
evald_v = zapped_v `setIdUnfolding` mkOtherCon []
evald_v = zapped_v `setIdUnfolding` evaldUnfolding
go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
-- If the case binder is alive, then we add the unfolding
......
......@@ -7,7 +7,7 @@ module Unify (
gadtRefineTys, BindFlag(..),
coreRefineTys,
coreRefineTys, TypeRefinement,
-- Re-export
MaybeErr(..)
......@@ -19,9 +19,10 @@ import Var ( Var, TyVar, tyVarKind )
import VarEnv
import VarSet
import Kind ( isSubKind )
import Type ( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta,
import Type ( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, mkTyVarTys,
TvSubstEnv, emptyTvSubstEnv, TvSubst(..), substTy, tcEqTypeX )
import TypeRep ( Type(..), PredType(..), funTyCon )
import DataCon ( DataCon, dataConResTy )
import Util ( snocView )
import ErrUtils ( Message )
import Outputable
......@@ -207,23 +208,36 @@ tcUnifyTys bind_fn tys1 tys2
tvs2 = tyVarsOfTypes tys2
----------------------------
coreRefineTys :: InScopeSet -- Superset of free vars of either type
-> [TyVar] -- Try to unify these
-> Type -- Both types should be a fixed point
-> Type -- of the incoming substitution
-> Maybe TvSubstEnv -- In-scope set is unaffected
-- Used by Core Lint and the simplifier. Takes a full apply-once substitution.
-- The incoming substitution's in-scope set should mention all the variables free
-- in the incoming types
coreRefineTys in_scope ex_tvs ty1 ty2
= maybeErrToMaybe $ initUM (tryToBind (mkVarSet ex_tvs)) $
coreRefineTys :: InScopeSet -- Superset of free vars of either type
-> DataCon -> [TyVar] -- Case pattern (con tv1 .. tvn ...)
-> Type -- Type of scrutinee
-> Maybe TypeRefinement
type TypeRefinement = (TvSubstEnv, Bool)
-- The Bool is True iff all the bindings in the
-- env are for the pattern type variables
-- In this case, there is no type refinement
-- for already-in-scope type variables
-- Used by Core Lint and the simplifier.
coreRefineTys in_scope con tvs scrut_ty
= maybeErrToMaybe $ initUM (tryToBind tv_set) $
do { -- Run the unifier, starting with an empty env
; subst_env <- unify emptyTvSubstEnv ty1 ty2
; subst_env <- unify emptyTvSubstEnv pat_res_ty scrut_ty
-- Find the fixed point of the resulting non-idempotent substitution
; let subst = TvSubst in_scope subst_env_fixpt
subst_env_fixpt = mapVarEnv (substTy subst) subst_env
; return subst_env_fixpt }
; return (subst_env_fixpt, all_bound_here subst_env) }
where
pat_res_ty = dataConResTy con (mkTyVarTys tvs)
-- 'tvs' are the tyvars bound by the pattern
tv_set = mkVarSet tvs
all_bound_here env = all bound_here (varEnvKeys env)
bound_here uniq = elemVarSetByKey uniq tv_set
----------------------------
gadtRefineTys
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment