diff options
Diffstat (limited to 'compiler/simplCore/SimplEnv.hs')
| -rw-r--r-- | compiler/simplCore/SimplEnv.hs | 391 |
1 files changed, 231 insertions, 160 deletions
diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs index 9316ec08af..1d55f359fa 100644 --- a/compiler/simplCore/SimplEnv.hs +++ b/compiler/simplCore/SimplEnv.hs @@ -8,14 +8,14 @@ module SimplEnv ( -- * The simplifier mode - setMode, getMode, updMode, + setMode, getMode, updMode, seDynFlags, -- * Environments - SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract + SimplEnv(..), pprSimplEnv, -- Temp not abstract mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst, zapSubstEnv, setSubstEnv, - getInScope, setInScopeAndZapFloats, + getInScope, setInScopeFromE, setInScopeFromF, setInScopeSet, modifyInScope, addNewInScopeIds, getSimplRules, @@ -29,19 +29,26 @@ module SimplEnv ( substCo, substCoVar, -- * Floats - Floats, emptyFloats, isEmptyFloats, - addNonRec, addLetFloats, addFloats, extendFloats, addFlts, - wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats, - doFloatFromRhs, getFloatBinds, - - JoinFloat, JoinFloats, emptyJoinFloats, isEmptyJoinFloats, - wrapJoinFloats, wrapJoinFloatsX, zapJoinFloats, addJoinFloats + SimplFloats(..), emptyFloats, mkRecFloats, + mkFloatBind, addLetFloats, addJoinFloats, addFloats, + extendFloats, wrapFloats, + doFloatFromRhs, getTopFloatBinds, + + -- * LetFloats + LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat, + addLetFlts, mapLetFloats, + + -- * JoinFloats + JoinFloat, JoinFloats, emptyJoinFloats, + wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts ) where #include "HsVersions.h" +import GhcPrelude + import SimplMonad -import CoreMonad ( SimplifierMode(..) ) +import CoreMonad ( SimplMode(..) ) import CoreSyn import CoreUtils import Var @@ -50,6 +57,7 @@ import VarSet import OrdList import Id import MkCore ( mkWildValBinder ) +import DynFlags ( DynFlags ) import TysWiredIn import qualified Type import Type hiding ( substTy, substTyVar, substTyVarBndr ) @@ -77,12 +85,12 @@ data SimplEnv -- Static in the sense of lexically scoped, -- wrt the original expression - seMode :: SimplifierMode, + seMode :: SimplMode -- The current substitution - seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType - seCvSubst :: CvSubstEnv, -- InCoVar |--> OutCoercion - seIdSubst :: SimplIdSubst, -- InId |--> OutExpr + , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType + , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion + , seIdSubst :: SimplIdSubst -- InId |--> OutExpr ----------- Dynamic part of the environment ----------- -- Dynamic in the sense of describing the setup where @@ -90,23 +98,40 @@ data SimplEnv -- The current set of in-scope variables -- They are all OutVars, and all bound in this module - seInScope :: InScopeSet, -- OutVars only - -- Includes all variables bound - -- by seLetFloats and seJoinFloats + , seInScope :: InScopeSet -- OutVars only + } - -- Ordinary bindings - seLetFloats :: Floats, - -- See Note [Simplifier floats] +data SimplFloats + = SimplFloats + { -- Ordinary let bindings + sfLetFloats :: LetFloats + -- See Note [LetFloats] -- Join points - seJoinFloats :: JoinFloats + , sfJoinFloats :: JoinFloats -- Handled separately; they don't go very far - -- We consider these to be /inside/ seLetFloats + -- We consider these to be /inside/ sfLetFloats -- because join points can refer to ordinary bindings, -- but not vice versa - } -type StaticEnv = SimplEnv -- Just the static part is relevant + -- Includes all variables bound by sfLetFloats and + -- sfJoinFloats, plus at least whatever is in scope where + -- these bindings land up. + , sfInScope :: InScopeSet -- All OutVars + } + +instance Outputable SimplFloats where + ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) + = text "SimplFloats" + <+> braces (vcat [ text "lets: " <+> ppr lf + , text "joins:" <+> ppr jf + , text "in_scope:" <+> ppr is ]) + +emptyFloats :: SimplEnv -> SimplFloats +emptyFloats env + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = emptyJoinFloats + , sfInScope = seInScope env } pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective @@ -241,12 +266,10 @@ need to know at the occurrence site that the variable is a join point so that we know to drop the context. Thus we remember which join points we're substituting. -} -mkSimplEnv :: SimplifierMode -> SimplEnv +mkSimplEnv :: SimplMode -> SimplEnv mkSimplEnv mode = SimplEnv { seMode = mode , seInScope = init_in_scope - , seLetFloats = emptyFloats - , seJoinFloats = emptyJoinFloats , seTvSubst = emptyVarEnv , seCvSubst = emptyVarEnv , seIdSubst = emptyVarEnv } @@ -276,13 +299,16 @@ wild-ids before doing much else. It's a very dark corner of GHC. Maybe it should be cleaned up. -} -getMode :: SimplEnv -> SimplifierMode +getMode :: SimplEnv -> SimplMode getMode env = seMode env -setMode :: SimplifierMode -> SimplEnv -> SimplEnv +seDynFlags :: SimplEnv -> DynFlags +seDynFlags env = sm_dflags (seMode env) + +setMode :: SimplMode -> SimplEnv -> SimplEnv setMode mode env = env { seMode = mode } -updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv +updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv updMode upd env = env { seMode = upd (seMode env) } --------------------- @@ -293,7 +319,7 @@ extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res - = ASSERT( isTyVar var ) + = ASSERT2( isTyVar var, ppr var $$ ppr res ) env {seTvSubst = extendVarEnv tsubst var res} extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv @@ -308,19 +334,12 @@ getInScope env = seInScope env setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv setInScopeSet env in_scope = env {seInScope = in_scope} -setInScopeAndZapFloats :: SimplEnv -> SimplEnv -> SimplEnv --- Set the in-scope set, and *zap* the floats -setInScopeAndZapFloats env env_with_scope - = env { seInScope = seInScope env_with_scope, - seLetFloats = emptyFloats, - seJoinFloats = emptyJoinFloats } +setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv +-- See Note [Setting the right in-scope set] +setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env } -setFloats :: SimplEnv -> SimplEnv -> SimplEnv --- Set the in-scope set *and* the floats -setFloats env env_with_floats - = env { seInScope = seInScope env_with_floats, - seLetFloats = seLetFloats env_with_floats, - seJoinFloats = seJoinFloats env_with_floats } +setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv +setInScopeFromF env floats = env { seInScope = sfInScope floats } addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv -- The new Ids are guaranteed to be freshly allocated @@ -340,6 +359,30 @@ modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv modifyInScope env@(SimplEnv {seInScope = in_scope}) v = env {seInScope = extendInScopeSet in_scope v} +{- Note [Setting the right in-scope set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + \x. (let x = e in b) arg[x] +where the let shadows the lambda. Really this means something like + \x1. (let x2 = e in b) arg[x1] + +- When we capture the 'arg' in an ApplyToVal continuation, we capture + the environment, which says what 'x' is bound to, namely x1 + +- Then that continuation gets pushed under the let + +- Finally we simplify 'arg'. We want + - the static, lexical environment bindig x :-> x1 + - the in-scopeset from "here", under the 'let' which includes + both x1 and x2 + +It's important to have the right in-scope set, else we may rename a +variable to one that is already in scope. So we must pick up the +in-scope set from "here", but otherwise use the environment we +captured along with 'arg'. This transfer of in-scope set is done by +setInScopeFromE. +-} + --------------------- zapSubstEnv :: SimplEnv -> SimplEnv zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} @@ -353,13 +396,13 @@ mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = Co {- ************************************************************************ * * -\subsection{Floats} +\subsection{LetFloats} * * ************************************************************************ -Note [Simplifier floats] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The Floats is a bunch of bindings, classified by a FloatFlag. +Note [LetFloats] +~~~~~~~~~~~~~~~~ +The LetFloats is a bunch of bindings, classified by a FloatFlag. * All of them satisfy the let/app invariant @@ -378,8 +421,8 @@ Can't happen: NonRec x# (f y) -- Might diverge; does not satisfy let/app -} -data Floats = Floats (OrdList OutBind) FloatFlag - -- See Note [Simplifier floats] +data LetFloats = LetFloats (OrdList OutBind) FloatFlag + -- See Note [LetFloats] type JoinFloat = OutBind type JoinFloats = OrdList JoinFloat @@ -401,12 +444,12 @@ data FloatFlag -- and not guaranteed cheap -- Do not float these bindings out of a lazy let -instance Outputable Floats where - ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds) +instance Outputable LetFloats where + ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds) instance Outputable FloatFlag where - ppr FltLifted = text "FltLifted" - ppr FltOkSpec = text "FltOkSpec" + ppr FltLifted = text "FltLifted" + ppr FltOkSpec = text "FltOkSpec" ppr FltCareful = text "FltCareful" andFF :: FloatFlag -> FloatFlag -> FloatFlag @@ -415,9 +458,9 @@ andFF FltOkSpec FltCareful = FltCareful andFF FltOkSpec _ = FltOkSpec andFF FltLifted flt = flt -doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool +doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool -- If you change this function look also at FloatIn.noFloatFromRhs -doFloatFromRhs lvl rec str rhs (SimplEnv {seLetFloats = Floats fs ff}) +doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs = not (isNilOL fs) && want_to_float && can_float where want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs @@ -439,23 +482,23 @@ But there are so we must take the 'or' of the two. -} -emptyFloats :: Floats -emptyFloats = Floats nilOL FltLifted +emptyLetFloats :: LetFloats +emptyLetFloats = LetFloats nilOL FltLifted emptyJoinFloats :: JoinFloats emptyJoinFloats = nilOL -unitFloat :: OutBind -> Floats +unitLetFloat :: OutBind -> LetFloats -- This key function constructs a singleton float with the right form -unitFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind)) - Floats (unitOL bind) (flag bind) +unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind)) + LetFloats (unitOL bind) (flag bind) where flag (Rec {}) = FltLifted flag (NonRec bndr rhs) | not (isStrictId bndr) = FltLifted - | exprIsLiteralString rhs = FltLifted + | exprIsTickedString rhs = FltLifted -- String literals can be floated freely. - -- See Note [CoreSyn top-level string ltierals] in CoreSyn. + -- See Note [CoreSyn top-level string literals] in CoreSyn. | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr ) FltCareful @@ -465,138 +508,132 @@ unitJoinFloat :: OutBind -> JoinFloats unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind)) unitOL bind -addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv --- Add a non-recursive binding and extend the in-scope set --- The latter is important; the binder may already be in the --- in-scope set (although it might also have been created with newId) --- but it may now have more IdInfo -addNonRec env@(SimplEnv { seLetFloats = floats - , seJoinFloats = jfloats - , seInScope = in_scope }) - id rhs - | isJoinId id -- This test incidentally forces the Id, and hence - -- its IdInfo, and hence any inner substitutions - = env { seInScope = in_scope' - , seLetFloats = floats - , seJoinFloats = jfloats' } - | otherwise - = env { seInScope = in_scope' - , seLetFloats = floats' - , seJoinFloats = jfloats } +mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv) +-- Make a singleton SimplFloats, and +-- extend the incoming SimplEnv's in-scope set with its binders +-- These binders may already be in the in-scope set, +-- but may have by now been augmented with more IdInfo +mkFloatBind env bind + = (floats, env { seInScope = in_scope' }) where - bind = NonRec id rhs - in_scope' = extendInScopeSet in_scope id - floats' = floats `addFlts` unitFloat bind - jfloats' = jfloats `addJoinFlts` unitJoinFloat bind - -extendFloats :: SimplEnv -> OutBind -> SimplEnv + floats + | isJoinBind bind + = SimplFloats { sfLetFloats = emptyLetFloats + , sfJoinFloats = unitJoinFloat bind + , sfInScope = in_scope' } + | otherwise + = SimplFloats { sfLetFloats = unitLetFloat bind + , sfJoinFloats = emptyJoinFloats + , sfInScope = in_scope' } + + in_scope' = seInScope env `extendInScopeSetBind` bind + +extendFloats :: SimplFloats -> OutBind -> SimplFloats -- Add this binding to the floats, and extend the in-scope env too -extendFloats env@(SimplEnv { seLetFloats = floats - , seJoinFloats = jfloats - , seInScope = in_scope }) +extendFloats (SimplFloats { sfLetFloats = floats + , sfJoinFloats = jfloats + , sfInScope = in_scope }) bind | isJoinBind bind - = env { seInScope = in_scope' - , seLetFloats = floats - , seJoinFloats = jfloats' } + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats + , sfJoinFloats = jfloats' } | otherwise - = env { seInScope = in_scope' - , seLetFloats = floats' - , seJoinFloats = jfloats } + = SimplFloats { sfInScope = in_scope' + , sfLetFloats = floats' + , sfJoinFloats = jfloats } where - bndrs = bindersOf bind - - in_scope' = extendInScopeSetList in_scope bndrs - floats' = floats `addFlts` unitFloat bind + in_scope' = in_scope `extendInScopeSetBind` bind + floats' = floats `addLetFlts` unitLetFloat bind jfloats' = jfloats `addJoinFlts` unitJoinFloat bind -addLetFloats :: SimplEnv -> SimplEnv -> SimplEnv +addLetFloats :: SimplFloats -> LetFloats -> SimplFloats -- Add the let-floats for env2 to env1; -- *plus* the in-scope set for env2, which is bigger -- than that for env1 -addLetFloats env1 env2 - = env1 { seLetFloats = seLetFloats env1 `addFlts` seLetFloats env2 - , seInScope = seInScope env2 } - -addFloats :: SimplEnv -> SimplEnv -> SimplEnv +addLetFloats floats let_floats@(LetFloats binds _) + = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats + , sfInScope = foldlOL extendInScopeSetBind + (sfInScope floats) binds } + +addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats +addJoinFloats floats join_floats + = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats + , sfInScope = foldlOL extendInScopeSetBind + (sfInScope floats) join_floats } + +extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet +extendInScopeSetBind in_scope bind + = extendInScopeSetList in_scope (bindersOf bind) + +addFloats :: SimplFloats -> SimplFloats -> SimplFloats -- Add both let-floats and join-floats for env2 to env1; -- *plus* the in-scope set for env2, which is bigger -- than that for env1 -addFloats env1 env2 - = env1 { seLetFloats = seLetFloats env1 `addFlts` seLetFloats env2 - , seJoinFloats = seJoinFloats env1 `addJoinFlts` seJoinFloats env2 - , seInScope = seInScope env2 } +addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 }) + (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope }) + = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2 + , sfJoinFloats = jf1 `addJoinFlts` jf2 + , sfInScope = in_scope } -addFlts :: Floats -> Floats -> Floats -addFlts (Floats bs1 l1) (Floats bs2 l2) - = Floats (bs1 `appOL` bs2) (l1 `andFF` l2) +addLetFlts :: LetFloats -> LetFloats -> LetFloats +addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2) + = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2) + +letFloatBinds :: LetFloats -> [CoreBind] +letFloatBinds (LetFloats bs _) = fromOL bs addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats addJoinFlts = appOL -zapFloats :: SimplEnv -> SimplEnv -zapFloats env = env { seLetFloats = emptyFloats - , seJoinFloats = emptyJoinFloats } - -zapJoinFloats :: SimplEnv -> SimplEnv -zapJoinFloats env = env { seJoinFloats = emptyJoinFloats } - -addJoinFloats :: SimplEnv -> JoinFloats -> SimplEnv -addJoinFloats env@(SimplEnv { seJoinFloats = fb1 }) fb2 - = env { seJoinFloats = fb1 `addJoinFlts` fb2 } - -addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv +mkRecFloats :: SimplFloats -> SimplFloats -- Flattens the floats from env2 into a single Rec group, --- prepends the floats from env1, and puts the result back in env2 --- This is all very specific to the way recursive bindings are --- handled; see Simplify.simplRecBind -addRecFloats env1 env2@(SimplEnv {seLetFloats = Floats bs ff - ,seJoinFloats = jbs }) +-- They must either all be lifted LetFloats or all JoinFloats +mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff + , sfJoinFloats = jbs + , sfInScope = in_scope }) = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) - env2 {seLetFloats = seLetFloats env1 `addFlts` floats' - ,seJoinFloats = seJoinFloats env1 `addJoinFlts` jfloats'} + ASSERT2( isNilOL bs || isNilOL jbs, ppr floats ) + SimplFloats { sfLetFloats = floats' + , sfJoinFloats = jfloats' + , sfInScope = in_scope } where - floats' | isNilOL bs = emptyFloats - | otherwise = unitFloat (Rec (flattenBinds (fromOL bs))) + floats' | isNilOL bs = emptyLetFloats + | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) jfloats' | isNilOL jbs = emptyJoinFloats | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) -wrapFloats :: SimplEnv -> OutExpr -> OutExpr +wrapFloats :: SimplFloats -> OutExpr -> OutExpr -- Wrap the floats around the expression; they should all -- satisfy the let/app invariant, so mkLets should do the job just fine -wrapFloats (SimplEnv { seLetFloats = Floats bs _ - , seJoinFloats = jbs }) body +wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _ + , sfJoinFloats = jbs }) body = foldrOL Let (wrapJoinFloats jbs body) bs -- Note: Always safe to put the joins on the inside -- since the values can't refer to them -wrapJoinFloatsX :: SimplEnv -> OutExpr -> (SimplEnv, OutExpr) --- Wrap the seJoinFloats of the env around the expression, +wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) +-- Wrap the sfJoinFloats of the env around the expression, -- and take them out of the SimplEnv -wrapJoinFloatsX env@(SimplEnv { seJoinFloats = jbs }) body - = (zapJoinFloats env, wrapJoinFloats jbs body) +wrapJoinFloatsX floats body + = ( floats { sfJoinFloats = emptyJoinFloats } + , wrapJoinFloats (sfJoinFloats floats) body ) wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr --- Wrap the seJoinFloats of the env around the expression, +-- Wrap the sfJoinFloats of the env around the expression, -- and take them out of the SimplEnv wrapJoinFloats join_floats body = foldrOL Let body join_floats -getFloatBinds :: SimplEnv -> [CoreBind] -getFloatBinds (SimplEnv {seLetFloats = Floats bs _, seJoinFloats = jbs}) - = fromOL bs ++ fromOL jbs - -isEmptyFloats :: SimplEnv -> Bool -isEmptyFloats env@(SimplEnv {seLetFloats = Floats bs _}) - = isNilOL bs && isEmptyJoinFloats env - -isEmptyJoinFloats :: SimplEnv -> Bool -isEmptyJoinFloats (SimplEnv {seJoinFloats = jbs}) - = isNilOL jbs +getTopFloatBinds :: SimplFloats -> [CoreBind] +getTopFloatBinds (SimplFloats { sfLetFloats = lbs + , sfJoinFloats = jbs}) + = ASSERT( isNilOL jbs ) -- Can't be any top-level join bindings + letFloatBinds lbs -mapFloats :: Floats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> Floats -mapFloats (Floats fs ff) fun - = Floats (mapOL app fs) ff +mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats +mapLetFloats (LetFloats fs ff) fun + = LetFloats (mapOL app fs) ff where app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' app (Rec bs) = Rec (map fun bs) @@ -657,6 +694,34 @@ lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v These functions are in the monad only so that they can be made strict via seq. + +Note [Return type for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + (join j :: Char -> Int -> Int) 77 + ( j x = \y. y + ord x ) + (in case v of ) + ( A -> j 'x' ) + ( B -> j 'y' ) + ( C -> <blah> ) + +The simplifier pushes the "apply to 77" continuation inwards to give + + join j :: Char -> Int + j x = (\y. y + ord x) 77 + in case v of + A -> j 'x' + B -> j 'y' + C -> <blah> 77 + +Notice that the "apply to 77" continuation went into the RHS of the +join point. And that meant that the return type of the join point +changed!! + +That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr +takes a (Just res_ty) argument so that it knows to do the type-changing +thing. -} simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) @@ -685,8 +750,9 @@ simplNonRecBndr env id --------------- simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr -> SimplM (SimplEnv, OutBndr) --- A non-recursive let binder for a join point; context being pushed inward may --- change the type +-- A non-recursive let binder for a join point; +-- context being pushed inward may change the type +-- See Note [Return type for join points] simplNonRecJoinBndr env res_ty id = do { let (env1, id1) = substIdBndr (Just res_ty) env id ; seqId id1 `seq` return (env1, id1) } @@ -701,8 +767,9 @@ simplRecBndrs env@(SimplEnv {}) ids --------------- simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv --- Recursive let binders for join points; context being pushed inward may --- change types +-- Recursive let binders for join points; +-- context being pushed inward may change types +-- See Note [Return type for join points] simplRecJoinBndrs env@(SimplEnv {}) res_ty ids = ASSERT(all isJoinId ids) do { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids @@ -718,6 +785,7 @@ substIdBndr new_res_ty env bndr --------------- substNonCoVarIdBndr :: Maybe OutType -- New result type, if a join binder + -- See Note [Return type for join points] -> SimplEnv -> InBndr -- Env and binder to transform -> (SimplEnv, OutBndr) @@ -748,10 +816,13 @@ substNonCoVarIdBndr new_res_ty where id1 = uniqAway in_scope old_id id2 = substIdType env id1 + id3 | Just res_ty <- new_res_ty = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2) + -- See Note [Return type for join points] | otherwise = id2 + new_id = zapFragileIdInfo id3 -- Zaps rules, worker-info, unfolding -- and fragile OccInfo |