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,
import SimplMonad
import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
- arityInfo, setArityInfo, workerInfo, setWorkerInfo,
+ arityInfo, workerInfo, setWorkerInfo,
unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
- unknownArity, workerExists
+ workerExists
)
import CoreSyn
-import Unify ( TypeRefinement )
import Rules ( RuleBase )
import CoreUtils ( needsCaseBinding )
import CostCentre ( CostCentreStack, subsumedCCS )
import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
import qualified Type ( substTy, substTyVarBndr )
-import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
+import Type ( Type, TvSubst(..), TvSubstEnv,
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}
%************************************************************************
data SimplSR
= DoneEx OutExpr -- Completed term
- | DoneId OutId OccInfo -- Completed term variable, with occurrence info
+ | DoneId OutId -- Completed term variable
| ContEx TvSubstEnv -- A suspended substitution
SimplIdSubst
InExpr
a77 -> a77
from the substitution, when we decide not to clone a77, but it's quite
legitimate to put the mapping in the substitution anyway.
-
- Indeed, we do so when we want to pass fragile OccInfo to the
- occurrences of the variable; we add a substitution
- x77 -> DoneId x77 occ
- to record x's occurrence information.]
Furthermore, consider
let x = case k of I# x77 -> ... in
Of course, the substitution *must* applied! Things in its domain
simply aren't necessarily bound in the result.
-* substId adds a binding (DoneId new_id occ) to the substitution if
- EITHER the Id's unique has changed
- OR the Id has interesting occurrence information
- So in effect you can only get to interesting occurrence information
- by looking up the *old* Id; it's not really attached to the new id
- at all.
+* substId adds a binding (DoneId new_id) to the substitution if
+ the Id's unique has changed
+
Note, though that the substitution isn't necessarily extended
if the type changes. Why not? Because of the next point:
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}
%************************************************************************
%* *
substId :: SimplEnv -> Id -> SimplSR
substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
| not (isLocalId v)
- = DoneId v NoOccInfo
+ = DoneId v
| otherwise -- A local Id
= case lookupVarEnv ids v of
- Just (DoneId v occ) -> DoneId (refine v) occ
- Just res -> res
- Nothing -> let v' = refine v
- in DoneId v' (idOccInfo v')
- -- We don't put LoopBreakers in the substitution (unless then need
- -- to be cloned for name-clash rasons), so the idOccInfo is
- -- very important! If isFragileOcc returned True for
- -- loop breakers we could avoid this call, but at the expense
- -- of adding more to the substitution, and building new Ids
- -- a bit more often than really necessary
+ Just (DoneId v) -> DoneId (refine v)
+ Just res -> res
+ Nothing -> DoneId (refine 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 with 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
new_subst | new_id /= old_id
- = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
+ = extendVarEnv id_subst old_id (DoneId new_id)
| otherwise
= delVarEnv id_subst old_id
\end{code}
-- or there's some useful occurrence information
-- See the notes with substTyVarBndr for the delSubstEnv
occ_info = occInfo (idInfo old_id)
- new_subst | new_id /= old_id || isFragileOcc occ_info
- = extendVarEnv id_subst old_id (DoneId new_id occ_info)
+ new_subst | new_id /= old_id
+ = extendVarEnv id_subst old_id (DoneId new_id)
| otherwise
= delVarEnv id_subst old_id
\end{code}
wanted a RULE for a recursive function to apply in that function's
own right-hand side.
-NB 2: We do not transfer the arity (see Subst.substIdInfo)
-The arity of an Id should not be visible
-in its own RHS, else we eta-reduce
+NB 2: ARITY. We *do* transfer the arity. This is important, so that
+the arity of an Id is visible in its own RHS. For example:
+ f = \x. ....g (\y. f y)....
+We can eta-reduce the arg to g, becuase f is a value. But that
+needs to be visible.
+
+This interacts with the 'state hack' too:
+ f :: Bool -> IO Int
+ f = \x. case x of
+ True -> f y
+ False -> \s -> ...
+Can we eta-expand f? Only if we see that f has arity 1, and then we
+take advantage of the 'state hack' on the result of
+(f y) :: State# -> (State#, Int) to expand the arity one more.
+
+There is a disadvantage though. Making the arity visible in the RHA
+allows us to eta-reduce
f = \x -> f x
to
f = f
-which isn't sound. And it makes the arity in f's IdInfo greater than
-the manifest arity, which isn't good.
-The arity will get added later.
+which technically is not sound. This is very much a corner case, so
+I'm not worried about it. Another idea is to ensure that f's arity
+never decreases; its arity started as 1, and we should never eta-reduce
+below that.
-NB 3: It's important that we *do* transer the loop-breaker OccInfo,
-because that's what stops the Id getting inlined infinitely, in the body
-of the letrec.
+NB 3: OccInfo. It's important that we *do* transer the loop-breaker
+OccInfo, because that's what stops the Id getting inlined infinitely,
+in the body of the letrec.
NB 4: does no harm for non-recursive bindings
-- worker info
-- Zap the unfolding
-- Keep only 'robust' OccInfo
--- Zap Arity
+-- arity
--
-- Seq'ing on the returned IdInfo is enough to cause all the
-- substitutions to happen completely
substIdInfo subst info
| nothing_to_do = Nothing
| otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
- `setArityInfo` (if keep_arity then old_arity else unknownArity)
`setSpecInfo` CoreSubst.substSpec subst old_rules
`setWorkerInfo` CoreSubst.substWorker subst old_wrkr
`setUnfoldingInfo` noUnfolding)
-- setSpecInfo does a seq
-- setWorkerInfo does a seq
where
- nothing_to_do = keep_occ && keep_arity &&
+ nothing_to_do = keep_occ &&
isEmptySpecInfo old_rules &&
not (workerExists old_wrkr) &&
not (hasUnfolding (unfoldingInfo info))
- keep_occ = not (isFragileOcc old_occ)
- keep_arity = old_arity == unknownArity
- old_arity = arityInfo info
+ keep_occ = not (isFragileOcc old_occ)
old_occ = occInfo info
old_rules = specInfo info
old_wrkr = workerInfo info
mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
fiddle (DoneEx e) = e
- fiddle (DoneId v occ) = Var v
+ fiddle (DoneId v) = Var v
fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
substExpr :: SimplEnv -> CoreExpr -> CoreExpr
projects / ghc-hetmet.git / blobdiff