1{- 2(c) The AQUA Project, Glasgow University, 1993-1998 3 4\section[SimplMonad]{The simplifier Monad} 5-} 6 7{-# LANGUAGE CPP #-} 8 9module SimplEnv ( 10 -- * The simplifier mode 11 setMode, getMode, updMode, seDynFlags, 12 13 -- * Environments 14 SimplEnv(..), pprSimplEnv, -- Temp not abstract 15 mkSimplEnv, extendIdSubst, 16 SimplEnv.extendTvSubst, SimplEnv.extendCvSubst, 17 zapSubstEnv, setSubstEnv, 18 getInScope, setInScopeFromE, setInScopeFromF, 19 setInScopeSet, modifyInScope, addNewInScopeIds, 20 getSimplRules, 21 22 -- * Substitution results 23 SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, 24 25 -- * Simplifying 'Id' binders 26 simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, 27 simplBinder, simplBinders, 28 substTy, substTyVar, getTCvSubst, 29 substCo, substCoVar, 30 31 -- * Floats 32 SimplFloats(..), emptyFloats, mkRecFloats, 33 mkFloatBind, addLetFloats, addJoinFloats, addFloats, 34 extendFloats, wrapFloats, 35 doFloatFromRhs, getTopFloatBinds, 36 37 -- * LetFloats 38 LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat, 39 addLetFlts, mapLetFloats, 40 41 -- * JoinFloats 42 JoinFloat, JoinFloats, emptyJoinFloats, 43 wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts 44 ) where 45 46#include "HsVersions.h" 47 48import GhcPrelude 49 50import SimplMonad 51import CoreMonad ( SimplMode(..) ) 52import CoreSyn 53import CoreUtils 54import Var 55import VarEnv 56import VarSet 57import OrdList 58import Id 59import MkCore ( mkWildValBinder ) 60import DynFlags ( DynFlags ) 61import TysWiredIn 62import qualified Type 63import Type hiding ( substTy, substTyVar, substTyVarBndr ) 64import qualified Coercion 65import Coercion hiding ( substCo, substCoVar, substCoVarBndr ) 66import BasicTypes 67import MonadUtils 68import Outputable 69import Util 70import UniqFM ( pprUniqFM ) 71 72import Data.List (mapAccumL) 73 74{- 75************************************************************************ 76* * 77\subsubsection{The @SimplEnv@ type} 78* * 79************************************************************************ 80-} 81 82data SimplEnv 83 = SimplEnv { 84 ----------- Static part of the environment ----------- 85 -- Static in the sense of lexically scoped, 86 -- wrt the original expression 87 88 seMode :: SimplMode 89 90 -- The current substitution 91 , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType 92 , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion 93 , seIdSubst :: SimplIdSubst -- InId |--> OutExpr 94 95 ----------- Dynamic part of the environment ----------- 96 -- Dynamic in the sense of describing the setup where 97 -- the expression finally ends up 98 99 -- The current set of in-scope variables 100 -- They are all OutVars, and all bound in this module 101 , seInScope :: InScopeSet -- OutVars only 102 } 103 104data SimplFloats 105 = SimplFloats 106 { -- Ordinary let bindings 107 sfLetFloats :: LetFloats 108 -- See Note [LetFloats] 109 110 -- Join points 111 , sfJoinFloats :: JoinFloats 112 -- Handled separately; they don't go very far 113 -- We consider these to be /inside/ sfLetFloats 114 -- because join points can refer to ordinary bindings, 115 -- but not vice versa 116 117 -- Includes all variables bound by sfLetFloats and 118 -- sfJoinFloats, plus at least whatever is in scope where 119 -- these bindings land up. 120 , sfInScope :: InScopeSet -- All OutVars 121 } 122 123instance Outputable SimplFloats where 124 ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) 125 = text "SimplFloats" 126 <+> braces (vcat [ text "lets: " <+> ppr lf 127 , text "joins:" <+> ppr jf 128 , text "in_scope:" <+> ppr is ]) 129 130emptyFloats :: SimplEnv -> SimplFloats 131emptyFloats env 132 = SimplFloats { sfLetFloats = emptyLetFloats 133 , sfJoinFloats = emptyJoinFloats 134 , sfInScope = seInScope env } 135 136pprSimplEnv :: SimplEnv -> SDoc 137-- Used for debugging; selective 138pprSimplEnv env 139 = vcat [text "TvSubst:" <+> ppr (seTvSubst env), 140 text "CvSubst:" <+> ppr (seCvSubst env), 141 text "IdSubst:" <+> id_subst_doc, 142 text "InScope:" <+> in_scope_vars_doc 143 ] 144 where 145 id_subst_doc = pprUniqFM ppr (seIdSubst env) 146 in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env)) 147 (vcat . map ppr_one) 148 ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) 149 | otherwise = ppr v 150 151type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr 152 -- See Note [Extending the Subst] in CoreSubst 153 154-- | A substitution result. 155data SimplSR 156 = DoneEx OutExpr (Maybe JoinArity) 157 -- If x :-> DoneEx e ja is in the SimplIdSubst 158 -- then replace occurrences of x by e 159 -- and ja = Just a <=> x is a join-point of arity a 160 -- See Note [Join arity in SimplIdSubst] 161 162 163 | DoneId OutId 164 -- If x :-> DoneId v is in the SimplIdSubst 165 -- then replace occurrences of x by v 166 -- and v is a join-point of arity a 167 -- <=> x is a join-point of arity a 168 169 | ContEx TvSubstEnv -- A suspended substitution 170 CvSubstEnv 171 SimplIdSubst 172 InExpr 173 -- If x :-> ContEx tv cv id e is in the SimplISubst 174 -- then replace occurrences of x by (subst (tv,cv,id) e) 175 176instance Outputable SimplSR where 177 ppr (DoneId v) = text "DoneId" <+> ppr v 178 ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e 179 where 180 pp_mj = case mj of 181 Nothing -> empty 182 Just n -> parens (int n) 183 184 ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, 185 ppr (filter_env tv), ppr (filter_env id) -}] 186 -- where 187 -- fvs = exprFreeVars e 188 -- filter_env env = filterVarEnv_Directly keep env 189 -- keep uniq _ = uniq `elemUFM_Directly` fvs 190 191{- 192Note [SimplEnv invariants] 193~~~~~~~~~~~~~~~~~~~~~~~~~~ 194seInScope: 195 The in-scope part of Subst includes *all* in-scope TyVars and Ids 196 The elements of the set may have better IdInfo than the 197 occurrences of in-scope Ids, and (more important) they will 198 have a correctly-substituted type. So we use a lookup in this 199 set to replace occurrences 200 201 The Ids in the InScopeSet are replete with their Rules, 202 and as we gather info about the unfolding of an Id, we replace 203 it in the in-scope set. 204 205 The in-scope set is actually a mapping OutVar -> OutVar, and 206 in case expressions we sometimes bind 207 208seIdSubst: 209 The substitution is *apply-once* only, because InIds and OutIds 210 can overlap. 211 For example, we generally omit mappings 212 a77 -> a77 213 from the substitution, when we decide not to clone a77, but it's quite 214 legitimate to put the mapping in the substitution anyway. 215 216 Furthermore, consider 217 let x = case k of I# x77 -> ... in 218 let y = case k of I# x77 -> ... in ... 219 and suppose the body is strict in both x and y. Then the simplifier 220 will pull the first (case k) to the top; so the second (case k) will 221 cancel out, mapping x77 to, well, x77! But one is an in-Id and the 222 other is an out-Id. 223 224 Of course, the substitution *must* applied! Things in its domain 225 simply aren't necessarily bound in the result. 226 227* substId adds a binding (DoneId new_id) to the substitution if 228 the Id's unique has changed 229 230 Note, though that the substitution isn't necessarily extended 231 if the type of the Id changes. Why not? Because of the next point: 232 233* We *always, always* finish by looking up in the in-scope set 234 any variable that doesn't get a DoneEx or DoneVar hit in the substitution. 235 Reason: so that we never finish up with a "old" Id in the result. 236 An old Id might point to an old unfolding and so on... which gives a space 237 leak. 238 239 [The DoneEx and DoneVar hits map to "new" stuff.] 240 241* It follows that substExpr must not do a no-op if the substitution is empty. 242 substType is free to do so, however. 243 244* When we come to a let-binding (say) we generate new IdInfo, including an 245 unfolding, attach it to the binder, and add this newly adorned binder to 246 the in-scope set. So all subsequent occurrences of the binder will get 247 mapped to the full-adorned binder, which is also the one put in the 248 binding site. 249 250* The in-scope "set" usually maps x->x; we use it simply for its domain. 251 But sometimes we have two in-scope Ids that are synomyms, and should 252 map to the same target: x->x, y->x. Notably: 253 case y of x { ... } 254 That's why the "set" is actually a VarEnv Var 255 256Note [Join arity in SimplIdSubst] 257~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 258We have to remember which incoming variables are join points: the occurrences 259may not be marked correctly yet, and we're in change of propagating the change if 260OccurAnal makes something a join point). 261 262Normally the in-scope set is where we keep the latest information, but 263the in-scope set tracks only OutVars; if a binding is unconditionally 264inlined (via DoneEx), it never makes it into the in-scope set, and we 265need to know at the occurrence site that the variable is a join point 266so that we know to drop the context. Thus we remember which join 267points we're substituting. -} 268 269mkSimplEnv :: SimplMode -> SimplEnv 270mkSimplEnv mode 271 = SimplEnv { seMode = mode 272 , seInScope = init_in_scope 273 , seTvSubst = emptyVarEnv 274 , seCvSubst = emptyVarEnv 275 , seIdSubst = emptyVarEnv } 276 -- The top level "enclosing CC" is "SUBSUMED". 277 278init_in_scope :: InScopeSet 279init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy)) 280 -- See Note [WildCard binders] 281 282{- 283Note [WildCard binders] 284~~~~~~~~~~~~~~~~~~~~~~~ 285The program to be simplified may have wild binders 286 case e of wild { p -> ... } 287We want to *rename* them away, so that there are no 288occurrences of 'wild-id' (with wildCardKey). The easy 289way to do that is to start of with a representative 290Id in the in-scope set 291 292There can be *occurrences* of wild-id. For example, 293MkCore.mkCoreApp transforms 294 e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } 295This is ok provided 'wild' isn't free in 'e', and that's the delicate 296thing. Generally, you want to run the simplifier to get rid of the 297wild-ids before doing much else. 298 299It's a very dark corner of GHC. Maybe it should be cleaned up. 300-} 301 302getMode :: SimplEnv -> SimplMode 303getMode env = seMode env 304 305seDynFlags :: SimplEnv -> DynFlags 306seDynFlags env = sm_dflags (seMode env) 307 308setMode :: SimplMode -> SimplEnv -> SimplEnv 309setMode mode env = env { seMode = mode } 310 311updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv 312updMode upd env = env { seMode = upd (seMode env) } 313 314--------------------- 315extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv 316extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res 317 = ASSERT2( isId var && not (isCoVar var), ppr var ) 318 env { seIdSubst = extendVarEnv subst var res } 319 320extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv 321extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res 322 = ASSERT2( isTyVar var, ppr var $$ ppr res ) 323 env {seTvSubst = extendVarEnv tsubst var res} 324 325extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv 326extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co 327 = ASSERT( isCoVar var ) 328 env {seCvSubst = extendVarEnv csubst var co} 329 330--------------------- 331getInScope :: SimplEnv -> InScopeSet 332getInScope env = seInScope env 333 334setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv 335setInScopeSet env in_scope = env {seInScope = in_scope} 336 337setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv 338-- See Note [Setting the right in-scope set] 339setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env } 340 341setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv 342setInScopeFromF env floats = env { seInScope = sfInScope floats } 343 344addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv 345 -- The new Ids are guaranteed to be freshly allocated 346addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs 347 = env { seInScope = in_scope `extendInScopeSetList` vs, 348 seIdSubst = id_subst `delVarEnvList` vs } 349 -- Why delete? Consider 350 -- let x = a*b in (x, \x -> x+3) 351 -- We add [x |-> a*b] to the substitution, but we must 352 -- _delete_ it from the substitution when going inside 353 -- the (\x -> ...)! 354 355modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv 356-- The variable should already be in scope, but 357-- replace the existing version with this new one 358-- which has more information 359modifyInScope env@(SimplEnv {seInScope = in_scope}) v 360 = env {seInScope = extendInScopeSet in_scope v} 361 362{- Note [Setting the right in-scope set] 363~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 364Consider 365 \x. (let x = e in b) arg[x] 366where the let shadows the lambda. Really this means something like 367 \x1. (let x2 = e in b) arg[x1] 368 369- When we capture the 'arg' in an ApplyToVal continuation, we capture 370 the environment, which says what 'x' is bound to, namely x1 371 372- Then that continuation gets pushed under the let 373 374- Finally we simplify 'arg'. We want 375 - the static, lexical environment bindig x :-> x1 376 - the in-scopeset from "here", under the 'let' which includes 377 both x1 and x2 378 379It's important to have the right in-scope set, else we may rename a 380variable to one that is already in scope. So we must pick up the 381in-scope set from "here", but otherwise use the environment we 382captured along with 'arg'. This transfer of in-scope set is done by 383setInScopeFromE. 384-} 385 386--------------------- 387zapSubstEnv :: SimplEnv -> SimplEnv 388zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} 389 390setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv 391setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } 392 393mkContEx :: SimplEnv -> InExpr -> SimplSR 394mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e 395 396{- 397************************************************************************ 398* * 399\subsection{LetFloats} 400* * 401************************************************************************ 402 403Note [LetFloats] 404~~~~~~~~~~~~~~~~ 405The LetFloats is a bunch of bindings, classified by a FloatFlag. 406 407* All of them satisfy the let/app invariant 408 409Examples 410 411 NonRec x (y:ys) FltLifted 412 Rec [(x,rhs)] FltLifted 413 414 NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? 415 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n 416 417 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge 418 419Can't happen: 420 NonRec x# (a /# b) -- Might fail; does not satisfy let/app 421 NonRec x# (f y) -- Might diverge; does not satisfy let/app 422-} 423 424data LetFloats = LetFloats (OrdList OutBind) FloatFlag 425 -- See Note [LetFloats] 426 427type JoinFloat = OutBind 428type JoinFloats = OrdList JoinFloat 429 430data FloatFlag 431 = FltLifted -- All bindings are lifted and lazy *or* 432 -- consist of a single primitive string literal 433 -- Hence ok to float to top level, or recursive 434 435 | FltOkSpec -- All bindings are FltLifted *or* 436 -- strict (perhaps because unlifted, 437 -- perhaps because of a strict binder), 438 -- *and* ok-for-speculation 439 -- Hence ok to float out of the RHS 440 -- of a lazy non-recursive let binding 441 -- (but not to top level, or into a rec group) 442 443 | FltCareful -- At least one binding is strict (or unlifted) 444 -- and not guaranteed cheap 445 -- Do not float these bindings out of a lazy let 446 447instance Outputable LetFloats where 448 ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds) 449 450instance Outputable FloatFlag where 451 ppr FltLifted = text "FltLifted" 452 ppr FltOkSpec = text "FltOkSpec" 453 ppr FltCareful = text "FltCareful" 454 455andFF :: FloatFlag -> FloatFlag -> FloatFlag 456andFF FltCareful _ = FltCareful 457andFF FltOkSpec FltCareful = FltCareful 458andFF FltOkSpec _ = FltOkSpec 459andFF FltLifted flt = flt 460 461doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool 462-- If you change this function look also at FloatIn.noFloatFromRhs 463doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs 464 = not (isNilOL fs) && want_to_float && can_float 465 where 466 want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs 467 -- See Note [Float when cheap or expandable] 468 can_float = case ff of 469 FltLifted -> True 470 FltOkSpec -> isNotTopLevel lvl && isNonRec rec 471 FltCareful -> isNotTopLevel lvl && isNonRec rec && str 472 473{- 474Note [Float when cheap or expandable] 475~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 476We want to float a let from a let if the residual RHS is 477 a) cheap, such as (\x. blah) 478 b) expandable, such as (f b) if f is CONLIKE 479But there are 480 - cheap things that are not expandable (eg \x. expensive) 481 - expandable things that are not cheap (eg (f b) where b is CONLIKE) 482so we must take the 'or' of the two. 483-} 484 485emptyLetFloats :: LetFloats 486emptyLetFloats = LetFloats nilOL FltLifted 487 488emptyJoinFloats :: JoinFloats 489emptyJoinFloats = nilOL 490 491unitLetFloat :: OutBind -> LetFloats 492-- This key function constructs a singleton float with the right form 493unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind)) 494 LetFloats (unitOL bind) (flag bind) 495 where 496 flag (Rec {}) = FltLifted 497 flag (NonRec bndr rhs) 498 | not (isStrictId bndr) = FltLifted 499 | exprIsTickedString rhs = FltLifted 500 -- String literals can be floated freely. 501 -- See Note [CoreSyn top-level string literals] in CoreSyn. 502 | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) 503 | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr ) 504 FltCareful 505 -- Unlifted binders can only be let-bound if exprOkForSpeculation holds 506 507unitJoinFloat :: OutBind -> JoinFloats 508unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind)) 509 unitOL bind 510 511mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv) 512-- Make a singleton SimplFloats, and 513-- extend the incoming SimplEnv's in-scope set with its binders 514-- These binders may already be in the in-scope set, 515-- but may have by now been augmented with more IdInfo 516mkFloatBind env bind 517 = (floats, env { seInScope = in_scope' }) 518 where 519 floats 520 | isJoinBind bind 521 = SimplFloats { sfLetFloats = emptyLetFloats 522 , sfJoinFloats = unitJoinFloat bind 523 , sfInScope = in_scope' } 524 | otherwise 525 = SimplFloats { sfLetFloats = unitLetFloat bind 526 , sfJoinFloats = emptyJoinFloats 527 , sfInScope = in_scope' } 528 529 in_scope' = seInScope env `extendInScopeSetBind` bind 530 531extendFloats :: SimplFloats -> OutBind -> SimplFloats 532-- Add this binding to the floats, and extend the in-scope env too 533extendFloats (SimplFloats { sfLetFloats = floats 534 , sfJoinFloats = jfloats 535 , sfInScope = in_scope }) 536 bind 537 | isJoinBind bind 538 = SimplFloats { sfInScope = in_scope' 539 , sfLetFloats = floats 540 , sfJoinFloats = jfloats' } 541 | otherwise 542 = SimplFloats { sfInScope = in_scope' 543 , sfLetFloats = floats' 544 , sfJoinFloats = jfloats } 545 where 546 in_scope' = in_scope `extendInScopeSetBind` bind 547 floats' = floats `addLetFlts` unitLetFloat bind 548 jfloats' = jfloats `addJoinFlts` unitJoinFloat bind 549 550addLetFloats :: SimplFloats -> LetFloats -> SimplFloats 551-- Add the let-floats for env2 to env1; 552-- *plus* the in-scope set for env2, which is bigger 553-- than that for env1 554addLetFloats floats let_floats@(LetFloats binds _) 555 = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats 556 , sfInScope = foldlOL extendInScopeSetBind 557 (sfInScope floats) binds } 558 559addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats 560addJoinFloats floats join_floats 561 = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats 562 , sfInScope = foldlOL extendInScopeSetBind 563 (sfInScope floats) join_floats } 564 565extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet 566extendInScopeSetBind in_scope bind 567 = extendInScopeSetList in_scope (bindersOf bind) 568 569addFloats :: SimplFloats -> SimplFloats -> SimplFloats 570-- Add both let-floats and join-floats for env2 to env1; 571-- *plus* the in-scope set for env2, which is bigger 572-- than that for env1 573addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 }) 574 (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope }) 575 = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2 576 , sfJoinFloats = jf1 `addJoinFlts` jf2 577 , sfInScope = in_scope } 578 579addLetFlts :: LetFloats -> LetFloats -> LetFloats 580addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2) 581 = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2) 582 583letFloatBinds :: LetFloats -> [CoreBind] 584letFloatBinds (LetFloats bs _) = fromOL bs 585 586addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats 587addJoinFlts = appOL 588 589mkRecFloats :: SimplFloats -> SimplFloats 590-- Flattens the floats from env2 into a single Rec group, 591-- They must either all be lifted LetFloats or all JoinFloats 592mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff 593 , sfJoinFloats = jbs 594 , sfInScope = in_scope }) 595 = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) 596 ASSERT2( isNilOL bs || isNilOL jbs, ppr floats ) 597 SimplFloats { sfLetFloats = floats' 598 , sfJoinFloats = jfloats' 599 , sfInScope = in_scope } 600 where 601 floats' | isNilOL bs = emptyLetFloats 602 | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) 603 jfloats' | isNilOL jbs = emptyJoinFloats 604 | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) 605 606wrapFloats :: SimplFloats -> OutExpr -> OutExpr 607-- Wrap the floats around the expression; they should all 608-- satisfy the let/app invariant, so mkLets should do the job just fine 609wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _ 610 , sfJoinFloats = jbs }) body 611 = foldrOL Let (wrapJoinFloats jbs body) bs 612 -- Note: Always safe to put the joins on the inside 613 -- since the values can't refer to them 614 615wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) 616-- Wrap the sfJoinFloats of the env around the expression, 617-- and take them out of the SimplEnv 618wrapJoinFloatsX floats body 619 = ( floats { sfJoinFloats = emptyJoinFloats } 620 , wrapJoinFloats (sfJoinFloats floats) body ) 621 622wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr 623-- Wrap the sfJoinFloats of the env around the expression, 624-- and take them out of the SimplEnv 625wrapJoinFloats join_floats body 626 = foldrOL Let body join_floats 627 628getTopFloatBinds :: SimplFloats -> [CoreBind] 629getTopFloatBinds (SimplFloats { sfLetFloats = lbs 630 , sfJoinFloats = jbs}) 631 = ASSERT( isNilOL jbs ) -- Can't be any top-level join bindings 632 letFloatBinds lbs 633 634mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats 635mapLetFloats (LetFloats fs ff) fun 636 = LetFloats (mapOL app fs) ff 637 where 638 app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' 639 app (Rec bs) = Rec (map fun bs) 640 641{- 642************************************************************************ 643* * 644 Substitution of Vars 645* * 646************************************************************************ 647 648Note [Global Ids in the substitution] 649~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 650We look up even a global (eg imported) Id in the substitution. Consider 651 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } 652The binder-swap in the occurrence analyser will add a binding 653for a LocalId version of g (with the same unique though): 654 case X.g_34 of b { (a,b) -> let g_34 = b in 655 ... case X.g_34 of { (p,q) -> ...} ... } 656So we want to look up the inner X.g_34 in the substitution, where we'll 657find that it has been substituted by b. (Or conceivably cloned.) 658-} 659 660substId :: SimplEnv -> InId -> SimplSR 661-- Returns DoneEx only on a non-Var expression 662substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v 663 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] 664 Nothing -> DoneId (refineFromInScope in_scope v) 665 Just (DoneId v) -> DoneId (refineFromInScope in_scope v) 666 Just res -> res -- DoneEx non-var, or ContEx 667 668 -- Get the most up-to-date thing from the in-scope set 669 -- Even though it isn't in the substitution, it may be in 670 -- the in-scope set with better IdInfo. 671 -- 672 -- See also Note [In-scope set as a substitution] in Simplify. 673 674refineFromInScope :: InScopeSet -> Var -> Var 675refineFromInScope in_scope v 676 | isLocalId v = case lookupInScope in_scope v of 677 Just v' -> v' 678 Nothing -> WARN( True, ppr v ) v -- This is an error! 679 | otherwise = v 680 681lookupRecBndr :: SimplEnv -> InId -> OutId 682-- Look up an Id which has been put into the envt by simplRecBndrs, 683-- but where we have not yet done its RHS 684lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v 685 = case lookupVarEnv ids v of 686 Just (DoneId v) -> v 687 Just _ -> pprPanic "lookupRecBndr" (ppr v) 688 Nothing -> refineFromInScope in_scope v 689 690{- 691************************************************************************ 692* * 693\section{Substituting an Id binder} 694* * 695************************************************************************ 696 697 698These functions are in the monad only so that they can be made strict via seq. 699 700Note [Return type for join points] 701~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 702Consider 703 704 (join j :: Char -> Int -> Int) 77 705 ( j x = \y. y + ord x ) 706 (in case v of ) 707 ( A -> j 'x' ) 708 ( B -> j 'y' ) 709 ( C -> <blah> ) 710 711The simplifier pushes the "apply to 77" continuation inwards to give 712 713 join j :: Char -> Int 714 j x = (\y. y + ord x) 77 715 in case v of 716 A -> j 'x' 717 B -> j 'y' 718 C -> <blah> 77 719 720Notice that the "apply to 77" continuation went into the RHS of the 721join point. And that meant that the return type of the join point 722changed!! 723 724That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr 725takes a (Just res_ty) argument so that it knows to do the type-changing 726thing. 727-} 728 729simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) 730simplBinders env bndrs = mapAccumLM simplBinder env bndrs 731 732------------- 733simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) 734-- Used for lambda and case-bound variables 735-- Clone Id if necessary, substitute type 736-- Return with IdInfo already substituted, but (fragile) occurrence info zapped 737-- The substitution is extended only if the variable is cloned, because 738-- we *don't* need to use it to track occurrence info. 739simplBinder env bndr 740 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr 741 ; seqTyVar tv `seq` return (env', tv) } 742 | otherwise = do { let (env', id) = substIdBndr Nothing env bndr 743 ; seqId id `seq` return (env', id) } 744 745--------------- 746simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) 747-- A non-recursive let binder 748simplNonRecBndr env id 749 = do { let (env1, id1) = substIdBndr Nothing env id 750 ; seqId id1 `seq` return (env1, id1) } 751 752--------------- 753simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr 754 -> SimplM (SimplEnv, OutBndr) 755-- A non-recursive let binder for a join point; 756-- context being pushed inward may change the type 757-- See Note [Return type for join points] 758simplNonRecJoinBndr env res_ty id 759 = do { let (env1, id1) = substIdBndr (Just res_ty) env id 760 ; seqId id1 `seq` return (env1, id1) } 761 762--------------- 763simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv 764-- Recursive let binders 765simplRecBndrs env@(SimplEnv {}) ids 766 = ASSERT(all (not . isJoinId) ids) 767 do { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids 768 ; seqIds ids1 `seq` return env1 } 769 770--------------- 771simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv 772-- Recursive let binders for join points; 773-- context being pushed inward may change types 774-- See Note [Return type for join points] 775simplRecJoinBndrs env@(SimplEnv {}) res_ty ids 776 = ASSERT(all isJoinId ids) 777 do { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids 778 ; seqIds ids1 `seq` return env1 } 779 780--------------- 781substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr) 782-- Might be a coercion variable 783substIdBndr new_res_ty env bndr 784 | isCoVar bndr = substCoVarBndr env bndr 785 | otherwise = substNonCoVarIdBndr new_res_ty env bndr 786 787--------------- 788substNonCoVarIdBndr 789 :: Maybe OutType -- New result type, if a join binder 790 -- See Note [Return type for join points] 791 -> SimplEnv 792 -> InBndr -- Env and binder to transform 793 -> (SimplEnv, OutBndr) 794-- Clone Id if necessary, substitute its type 795-- Return an Id with its 796-- * Type substituted 797-- * UnfoldingInfo, Rules, WorkerInfo zapped 798-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] 799-- * Robust info, retained especially arity and demand info, 800-- so that they are available to occurrences that occur in an 801-- earlier binding of a letrec 802-- 803-- For the robust info, see Note [Arity robustness] 804-- 805-- Augment the substitution if the unique changed 806-- Extend the in-scope set with the new Id 807-- 808-- Similar to CoreSubst.substIdBndr, except that 809-- the type of id_subst differs 810-- all fragile info is zapped 811substNonCoVarIdBndr new_res_ty 812 env@(SimplEnv { seInScope = in_scope 813 , seIdSubst = id_subst }) 814 old_id 815 = ASSERT2( not (isCoVar old_id), ppr old_id ) 816 (env { seInScope = in_scope `extendInScopeSet` new_id, 817 seIdSubst = new_subst }, new_id) 818 where 819 id1 = uniqAway in_scope old_id 820 id2 = substIdType env id1 821 822 id3 | Just res_ty <- new_res_ty 823 = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2) 824 -- See Note [Return type for join points] 825 | otherwise 826 = id2 827 828 new_id = zapFragileIdInfo id3 -- Zaps rules, worker-info, unfolding 829 -- and fragile OccInfo 830 831 -- Extend the substitution if the unique has changed, 832 -- or there's some useful occurrence information 833 -- See the notes with substTyVarBndr for the delSubstEnv 834 new_subst | new_id /= old_id 835 = extendVarEnv id_subst old_id (DoneId new_id) 836 | otherwise 837 = delVarEnv id_subst old_id 838 839------------------------------------ 840seqTyVar :: TyVar -> () 841seqTyVar b = b `seq` () 842 843seqId :: Id -> () 844seqId id = seqType (idType id) `seq` 845 idInfo id `seq` 846 () 847 848seqIds :: [Id] -> () 849seqIds [] = () 850seqIds (id:ids) = seqId id `seq` seqIds ids 851 852{- 853Note [Arity robustness] 854~~~~~~~~~~~~~~~~~~~~~~~ 855We *do* transfer the arity from from the in_id of a let binding to the 856out_id. This is important, so that the arity of an Id is visible in 857its own RHS. For example: 858 f = \x. ....g (\y. f y).... 859We can eta-reduce the arg to g, because f is a value. But that 860needs to be visible. 861 862This interacts with the 'state hack' too: 863 f :: Bool -> IO Int 864 f = \x. case x of 865 True -> f y 866 False -> \s -> ... 867Can we eta-expand f? Only if we see that f has arity 1, and then we 868take advantage of the 'state hack' on the result of 869(f y) :: State# -> (State#, Int) to expand the arity one more. 870 871There is a disadvantage though. Making the arity visible in the RHS 872allows us to eta-reduce 873 f = \x -> f x 874to 875 f = f 876which technically is not sound. This is very much a corner case, so 877I'm not worried about it. Another idea is to ensure that f's arity 878never decreases; its arity started as 1, and we should never eta-reduce 879below that. 880 881 882Note [Robust OccInfo] 883~~~~~~~~~~~~~~~~~~~~~ 884It's important that we *do* retain the loop-breaker OccInfo, because 885that's what stops the Id getting inlined infinitely, in the body of 886the letrec. 887-} 888 889 890{- 891************************************************************************ 892* * 893 Impedance matching to type substitution 894* * 895************************************************************************ 896-} 897 898getTCvSubst :: SimplEnv -> TCvSubst 899getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env 900 , seCvSubst = cv_env }) 901 = mkTCvSubst in_scope (tv_env, cv_env) 902 903substTy :: SimplEnv -> Type -> Type 904substTy env ty = Type.substTy (getTCvSubst env) ty 905 906substTyVar :: SimplEnv -> TyVar -> Type 907substTyVar env tv = Type.substTyVar (getTCvSubst env) tv 908 909substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) 910substTyVarBndr env tv 911 = case Type.substTyVarBndr (getTCvSubst env) tv of 912 (TCvSubst in_scope' tv_env' cv_env', tv') 913 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') 914 915substCoVar :: SimplEnv -> CoVar -> Coercion 916substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv 917 918substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) 919substCoVarBndr env cv 920 = case Coercion.substCoVarBndr (getTCvSubst env) cv of 921 (TCvSubst in_scope' tv_env' cv_env', cv') 922 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') 923 924substCo :: SimplEnv -> Coercion -> Coercion 925substCo env co = Coercion.substCo (getTCvSubst env) co 926 927------------------ 928substIdType :: SimplEnv -> Id -> Id 929substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id 930 | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) 931 || noFreeVarsOfType old_ty 932 = id 933 | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty) 934 -- The tyCoVarsOfType is cheaper than it looks 935 -- because we cache the free tyvars of the type 936 -- in a Note in the id's type itself 937 where 938 old_ty = idType id 939