OccurAnal.lhs 36.4 KB
 partain committed Jan 08, 1996 1 %  simonm committed Dec 02, 1998 2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  partain committed Jan 08, 1996 3 4 5 6 7 8 9 % %************************************************************************ %* * \section[OccurAnal]{Occurrence analysis pass} %* * %************************************************************************  partain committed Mar 19, 1996 10 11 The occurrence analyser re-typechecks a core expression, returning a new core expression with (hopefully) improved usage information.  partain committed Jan 08, 1996 12 13 14  \begin{code} module OccurAnal (  simonpj committed Jul 19, 2005 15  occurAnalysePgm, occurAnalyseExpr  partain committed Jan 08, 1996 16 17  ) where  twanvl committed Jan 26, 2008 18 19 -- XXX This define is a bit of a hack, and should be done more nicely #define FAST_STRING_NOT_NEEDED 1  simonm committed Jan 08, 1998 20 #include "HsVersions.h"  partain committed Apr 05, 1996 21 22  import CoreSyn  23 import CoreFVs  simonmar committed Aug 03, 2005 24 import CoreUtils ( exprIsTrivial, isDefaultAlt )  Simon Marlow committed Oct 09, 2007 25 26 import Id import IdInfo  twanvl committed Jan 26, 2008 27 import BasicTypes  simonm committed Dec 02, 1998 28 29 30 31  import VarSet import VarEnv  simonpj committed Mar 08, 2002 32 import Maybes ( orElse )  simonm committed Dec 02, 1998 33 import Digraph ( stronglyConnCompR, SCC(..) )  simonpj committed Sep 28, 2000 34 import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )  simonpj committed Jul 17, 2001 35 import Unique ( Unique )  Ian Lynagh committed Feb 07, 2008 36 import LazyUniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly )  Ian Lynagh committed Jul 02, 2007 37 import Util ( mapAndUnzip )  simonm committed Jan 08, 1998 38 import Outputable  Ian Lynagh committed Jul 02, 2007 39 40  import Data.List  partain committed Jan 08, 1996 41 42 43 44 45 46 47 48 49 50 51 52 \end{code} %************************************************************************ %* * \subsection[OccurAnal-main]{Counting occurrences: main function} %* * %************************************************************************ Here's the externally-callable interface: \begin{code}  simonpj committed Mar 07, 2005 53 54 occurAnalysePgm :: [CoreBind] -> [CoreBind] occurAnalysePgm binds  simonmar committed Apr 05, 2005 55  = snd (go initOccEnv binds)  simonpj committed Mar 07, 2005 56 57  where go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])  twanvl committed Jan 26, 2008 58  go _ []  simonpj committed Mar 07, 2005 59 60 61 62  = (emptyDetails, []) go env (bind:binds) = (final_usage, bind' ++ binds') where  simonmar committed Apr 05, 2005 63  (bs_usage, binds') = go env binds  simonpj committed Mar 07, 2005 64 65  (final_usage, bind') = occAnalBind env bind bs_usage  simonpj committed Jul 19, 2005 66 67 68 occurAnalyseExpr :: CoreExpr -> CoreExpr -- Do occurrence analysis, and discard occurence info returned occurAnalyseExpr expr = snd (occAnal initOccEnv expr)  partain committed Jan 08, 1996 69 70 \end{code}  simonpj committed Mar 09, 1998 71   partain committed Jan 08, 1996 72 73 74 75 76 77 78 79 80 81 82 %************************************************************************ %* * \subsection[OccurAnal-main]{Counting occurrences: main function} %* * %************************************************************************ Bindings ~~~~~~~~ \begin{code} occAnalBind :: OccEnv  simonm committed Dec 02, 1998 83  -> CoreBind  partain committed Jan 08, 1996 84 85  -> UsageDetails -- Usage details of scope -> (UsageDetails, -- Of the whole let(rec)  simonm committed Dec 02, 1998 86  [CoreBind])  partain committed Jan 08, 1996 87   partain committed Mar 19, 1996 88 occAnalBind env (NonRec binder rhs) body_usage  simonpj committed Jan 28, 1999 89  | not (binder usedIn body_usage) -- It's not mentioned  simonm committed Dec 02, 1998 90 91 92  = (body_usage, []) | otherwise -- It's mentioned in the body  simonpj@microsoft.com committed Oct 29, 2007 93  = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]  partain committed Mar 19, 1996 94  [NonRec tagged_binder rhs'])  partain committed Jan 08, 1996 95  where  simonpj@microsoft.com committed Oct 05, 2006 96 97  (body_usage', tagged_binder) = tagBinder body_usage binder (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs  partain committed Jan 08, 1996 98 99 \end{code}  simonpj@microsoft.com committed Oct 29, 2007 100 101 Note [Dead code] ~~~~~~~~~~~~~~~~  partain committed Jan 08, 1996 102 103 104 105 106 107 Dropping dead code for recursive bindings is done in a very simple way: the entire set of bindings is dropped if none of its binders are mentioned in its body; otherwise none are. This seems to miss an obvious improvement.  simonpj@microsoft.com committed Oct 29, 2007 108   partain committed Mar 19, 1996 109 110 111  letrec f = ...g... g = ...f... in  partain committed Jan 08, 1996 112 113 114 115 116 117 118  ...g... ===> letrec f = ...g... g = ...(...g...)... in ...g...  simonpj@microsoft.com committed Oct 29, 2007 119 120 121 Now 'f' is unused! But it's OK! Dependency analysis will sort this out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get dropped. It isn't easy to do a perfect job in one blow. Consider  partain committed Jan 08, 1996 122 123 124 125 126 127 128 129  letrec f = ...g... g = ...h... h = ...k... k = ...m... m = ...m... in ...m...  simonpj@microsoft.com committed Oct 29, 2007 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148  Note [Loop breaking and RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Loop breaking is surprisingly subtle. First read the section 4 of "Secrets of the GHC inliner". This describes our basic plan. However things are made quite a bit more complicated by RULES. Remember * Note [Rules are extra RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" keeps the specialised "children" alive. If the parent dies (because it isn't referenced any more), then the children will die too (unless they are already referenced directly). To that end, we build a Rec group for each cyclic strongly connected component, *treating f's rules as extra RHSs for 'f'*.  149 150 151 152  When we make the Rec groups we include variables free in *either* LHS *or* RHS of the rule. The former might seems silly, but see Note [Rule dependency info].  simonpj@microsoft.com committed Oct 29, 2007 153 154 155 156 157 158 159  So in Example [eftInt], eftInt and eftIntFB will be put in the same Rec, even though their 'main' RHSs are both non-recursive. * Note [Rules are visible in their own rec group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want the rules for 'f' to be visible in f's right-hand side.  160  And we'd like them to be visible in other functions in f's Rec  simonpj@microsoft.com committed Oct 29, 2007 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188  group. E.g. in Example [Specialisation rules] we want f' rule to be visible in both f's RHS, and fs's RHS. This means that we must simplify the RULEs first, before looking at any of the definitions. This is done by Simplify.simplRecBind, when it calls addLetIdInfo. * Note [Choosing loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We avoid infinite inlinings by choosing loop breakers, and ensuring that a loop breaker cuts each loop. But what is a "loop"? In particular, a RULES is like an equation for 'f' that is *always* inlined if it are applicable. We do *not* disable rules for loop-breakers. It's up to whoever makes the rules to make sure that the rules themselves alwasys terminate. See Note [Rules for recursive functions] in Simplify.lhs Hence, if f's RHS mentions g, and g has a RULE that mentions h, and h has a RULE that mentions f then we *must* choose f to be a loop breaker. In general, take the free variables of f's RHS, and augment it with all the variables reachable by RULES from those starting points. That is the whole reason for computing rule_fv_env in occAnalBind. (Of course we only consider free vars that are also binders in this Rec group.)  189 190 191 192  Note that when we compute this rule_fv_env, we only consider variables free in the *RHS* of the rule, in contrast to the way we build the Rec group in the first place (Note [Rule dependency info])  simonpj@microsoft.com committed Oct 29, 2007 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218  Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is chosen as a loop breaker, because their RHSs don't mention each other. And indeed both can be inlined safely. Note that the edges of the graph we use for computing loop breakers are not the same as the edges we use for computing the Rec blocks. That's why we compute rec_edges for the Rec block analysis loop_breaker_edges for the loop breaker analysis * Note [Weak loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~ There is a last nasty wrinkle. Suppose we have Rec { f = f_rhs RULE f [] = g h = h_rhs g = h ...more... } Remmber that we simplify the RULES before any RHS (see Note [Rules are visible in their own rec group] above).  simonpj@microsoft.com committed Jan 21, 2008 219  So we must *not* postInlineUnconditionally 'g', even though  simonpj@microsoft.com committed Oct 29, 2007 220 221 222 223 224 225 226 227 228 229 230 231 232  its RHS turns out to be trivial. (I'm assuming that 'g' is not choosen as a loop breaker.) We "solve" this by making g a "weak" or "rules-only" loop breaker, with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker has IAmLoopBreaker False. So Inline postInlineUnconditinoally IAmLoopBreaker False no no IAmLoopBreaker True yes no other yes yes The **sole** reason for this kind of loop breaker is so that  simonpj@microsoft.com committed Jan 21, 2008 233  postInlineUnconditionally does not fire. Ugh.  simonpj@microsoft.com committed Oct 29, 2007 234   235 236 237 238 239 240 241 242 243 244  * Note [Rule dependency info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The VarSet in a SpecInfo is used for dependency analysis in the occurrence analyser. We must track free vars in *both* lhs and rhs. Why both? Consider x = y RULE f x = 4 Then if we substitute y for x, we'd better do so in the rule's LHS too, so we'd better ensure the dependency is respected  simonpj@microsoft.com committed Oct 29, 2007 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277  Example [eftInt] ~~~~~~~~~~~~~~~ Example (from GHC.Enum): eftInt :: Int# -> Int# -> [Int] eftInt x y = ...(non-recursive)... {-# INLINE [0] eftIntFB #-} eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r eftIntFB c n x y = ...(non-recursive)... {-# RULES "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) "eftIntList" [1] eftIntFB (:) [] = eftInt #-} Example [Specialisation rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this group, which is typical of what SpecConstr builds: fs a = ....f (C a).... f x = ....f (C a).... {-# RULE f (C a) = fs a #-} So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify - fs is inlined (say it's small) - now there's another opportunity to apply the RULE This showed up when compiling Control.Concurrent.Chan.getChanContents.  partain committed Jan 08, 1996 278 279 280  \begin{code}  partain committed Mar 19, 1996 281 occAnalBind env (Rec pairs) body_usage  simonpj@microsoft.com committed Oct 29, 2007 282 283 284 285  | not (any (usedIn body_usage) bndrs) -- NB: look at body_usage, not total_usage = (body_usage, []) -- Dead code | otherwise = (final_usage, map ({-# SCC "occAnalBind.dofinal" #-} do_final_bind) sccs)  partain committed Jan 08, 1996 286  where  simonpj@microsoft.com committed Oct 29, 2007 287 288  bndrs = map fst pairs bndr_set = mkVarSet bndrs  partain committed Mar 19, 1996 289   simonpj@microsoft.com committed Oct 29, 2007 290 291 292 293 294 295 296 297 298  --------------------------------------- -- See Note [Loop breaking] --------------------------------------- -------------Dependency analysis ------------------------------ occ_anald :: [(Id, (UsageDetails, CoreExpr))] -- The UsageDetails here are strictly those arising from the RHS -- *not* from any rules in the Id occ_anald = [(bndr, occAnalRhs env bndr rhs) | (bndr,rhs) <- pairs]  partain committed Jan 08, 1996 299   simonpj@microsoft.com committed Oct 29, 2007 300 301 302 303 304  total_usage = foldl add_usage body_usage occ_anald add_usage body_usage (bndr, (rhs_usage, _)) = body_usage +++ addRuleUsage rhs_usage bndr (final_usage, tagged_bndrs) = tagBinders total_usage bndrs  simonpj@microsoft.com committed Jan 21, 2008 305  final_bndrs | isEmptyVarSet all_rule_fvs = tagged_bndrs  simonpj@microsoft.com committed Oct 29, 2007 306  | otherwise = map tag_rule_var tagged_bndrs  simonpj@microsoft.com committed Jan 21, 2008 307   simonpj@microsoft.com committed Oct 29, 2007 308 309  tag_rule_var bndr | bndr elemVarSet all_rule_fvs = makeLoopBreaker True bndr | otherwise = bndr  simonpj@microsoft.com committed Jan 21, 2008 310 311 312  all_rule_fvs = bndr_set intersectVarSet foldr (unionVarSet . idRuleVars) emptyVarSet bndrs -- Mark the binder with OccInfo saying "no preInlineUnconditionally" if -- it is used in any rule (lhs or rhs) of the recursive group  partain committed Jan 08, 1996 313 314  ---- stuff for dependency analysis of binds -------------------------------  simonpj@microsoft.com committed Oct 29, 2007 315 316 317 318 319 320 321 322 323 324 325  sccs :: [SCC (Node Details)] sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR rec_edges rec_edges :: [Node Details] -- The binders are tagged with correct occ-info rec_edges = {-# SCC "occAnalBind.assoc" #-} zipWith make_node final_bndrs occ_anald make_node tagged_bndr (_bndr, (rhs_usage, rhs)) = ((tagged_bndr, rhs, rhs_fvs), idUnique tagged_bndr, out_edges) where rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage out_edges = keysUFM (rhs_fvs unionVarSet idRuleVars tagged_bndr)  sof committed May 19, 1997 326 327 328 329 330 331 332  -- (a -> b) means a mentions b -- Given the usage details (a UFM that gives occ info for each free var of -- the RHS) we can get the list of free vars -- or rather their Int keys -- -- by just extracting the keys from the finite map. Grimy, but fast. -- Previously we had this: -- [ bndr | bndr <- bndrs,  simonm committed Dec 02, 1998 333  -- maybeToBool (lookupVarEnv rhs_usage bndr)]  sof committed May 19, 1997 334 335  -- which has n**2 cost, and this meant that edges_from alone -- consumed 10% of total runtime!  partain committed Jan 08, 1996 336   simonpj@microsoft.com committed Oct 05, 2006 337  ---- Stuff to "re-constitute" bindings from dependency-analysis info ------  simonpj@microsoft.com committed Oct 29, 2007 338 339 340 341  do_final_bind (AcyclicSCC ((bndr, rhs, _), _, _)) = NonRec bndr rhs do_final_bind (CyclicSCC cycle) | no_rules = Rec (reOrderCycle cycle) | otherwise = Rec (concatMap reOrderRec (stronglyConnCompR loop_breaker_edges))  342  where -- See Note [Choosing loop breakers] for looop_breker_edges  simonpj@microsoft.com committed Oct 29, 2007 343  loop_breaker_edges = map mk_node cycle  twanvl committed Jan 26, 2008 344  mk_node (details@(_bndr, _rhs, rhs_fvs), k, _) = (details, k, new_ks)  simonpj@microsoft.com committed Oct 29, 2007 345 346  where new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)  partain committed Jan 08, 1996 347   simonpj@microsoft.com committed Oct 29, 2007 348 349 350 351 352 353 354 355 356  ------------------------------------ rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules -- Domain is *subset* of bound vars (others have no rule fvs) rule_fv_env = rule_loop init_rule_fvs no_rules = null init_rule_fvs init_rule_fvs = [(b, rule_fvs) | b <- bndrs  357  , let rule_fvs = idRuleRhsVars b intersectVarSet bndr_set  simonpj@microsoft.com committed Oct 29, 2007 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372  , not (isEmptyVarSet rule_fvs)] rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint rule_loop fv_list | no_change = env | otherwise = rule_loop new_fv_list where env = mkVarEnv init_rule_fvs (no_change, new_fv_list) = mapAccumL bump True fv_list bump no_change (b,fvs) | new_fvs subVarSet fvs = (no_change, (b,fvs)) | otherwise = (False, (b,new_fvs unionVarSet fvs)) where new_fvs = extendFvs env emptyVarSet fvs  373 374 375 376 377 idRuleRhsVars :: Id -> VarSet -- Just the variables free on the *rhs* of a rule -- See Note [Choosing loop breakers] idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id)  simonpj@microsoft.com committed Oct 29, 2007 378 379 380 381 382 383 384 385 386 extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet -- (extendFVs env fvs s) returns (fvs union env(s)) extendFvs env fvs id_set = foldUFM_Directly add fvs id_set where add uniq _ fvs = case lookupVarEnv_Directly env uniq of Just fvs' -> fvs' unionVarSet fvs Nothing -> fvs  sof committed May 19, 1997 387 388 389 390 391 392 \end{code} @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic strongly connected component (there's guaranteed to be a cycle). It returns the same pairs, but a) in a better order,  simonpj@microsoft.com committed Oct 04, 2006 393  b) with some of the Ids having a IAmALoopBreaker pragma  sof committed May 19, 1997 394   simonpj@microsoft.com committed Oct 04, 2006 395 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means  sof committed May 19, 1997 396 397 398 399 400 401 402 403 that the simplifier can guarantee not to loop provided it never records an inlining for these no-inline guys. Furthermore, the order of the binds is such that if we neglect dependencies on the no-inline Ids then the binds are topologically sorted. This means that the simplifier will generally do a good job if it works from top bottom, recording inlinings for any Ids which aren't marked as "no-inline" as it goes.  simonm committed Dec 02, 1998 404 405 406 407 ============== [June 98: I don't understand the following paragraphs, and I've changed the a=b case again so that it isn't a special case any more.]  sof committed May 19, 1997 408 Here's a case that bit me:  partain committed Jan 08, 1996 409   sof committed May 19, 1997 410 411 412 413 414 415 416  letrec a = b b = \x. BIG in ...a...a...a.... Re-ordering doesn't change the order of bindings, but there was no loop-breaker.  sof committed Sep 04, 1997 417   sof committed May 19, 1997 418 419 My solution was to make a=b bindings record b as Many, rather like INLINE bindings. Perhaps something cleverer would suffice.  simonm committed Dec 02, 1998 420 ===============  sof committed May 19, 1997 421   sof committed Sep 04, 1997 422   sof committed May 19, 1997 423 \begin{code}  simonpj@microsoft.com committed Oct 04, 2006 424 425 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, -- which is gotten from the Id.  simonpj@microsoft.com committed Oct 29, 2007 426 427 428 type Details = (Id, -- Binder CoreExpr, -- RHS IdSet) -- RHS free vars (*not* include rules)  simonpj@microsoft.com committed Oct 03, 2006 429   simonpj@microsoft.com committed Oct 29, 2007 430 reOrderRec :: SCC (Node Details)  simonpj@microsoft.com committed Oct 05, 2006 431  -> [(Id,CoreExpr)]  simonpj@microsoft.com committed Oct 04, 2006 432 433 -- Sorted into a plausible order. Enough of the Ids have -- IAmALoopBreaker pragmas that there are no loops left.  simonpj@microsoft.com committed Oct 29, 2007 434 435 reOrderRec (AcyclicSCC ((bndr, rhs, _), _, _)) = [(bndr, rhs)] reOrderRec (CyclicSCC cycle) = reOrderCycle cycle  simonpj@microsoft.com committed Oct 04, 2006 436   simonpj@microsoft.com committed Oct 29, 2007 437 438 reOrderCycle :: [Node Details] -> [(Id,CoreExpr)] reOrderCycle []  simonpj@microsoft.com committed Oct 04, 2006 439  = panic "reOrderCycle"  simonpj@microsoft.com committed Oct 29, 2007 440 441 reOrderCycle [bind] -- Common case of simple self-recursion = [(makeLoopBreaker False bndr, rhs)]  sof committed May 19, 1997 442  where  simonpj@microsoft.com committed Oct 29, 2007 443  ((bndr, rhs, _), _, _) = bind  sof committed May 19, 1997 444   simonpj@microsoft.com committed Oct 29, 2007 445 reOrderCycle (bind : binds)  sof committed May 19, 1997 446 447  = -- Choose a loop breaker, mark it no-inline, -- do SCC analysis on the rest, and recursively sort them out  simonpj@microsoft.com committed Oct 29, 2007 448 449  concatMap reOrderRec (stronglyConnCompR unchosen) ++ [(makeLoopBreaker False bndr, rhs)]  sof committed May 19, 1997 450 451  where  simonpj@microsoft.com committed Oct 05, 2006 452  (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds  simonpj@microsoft.com committed Oct 29, 2007 453  (bndr, rhs, _) = chosen_bind  simonm committed Dec 02, 1998 454 455 456  -- This loop looks for the bind with the lowest score -- to pick as the loop breaker. The rest accumulate in  twanvl committed Jan 26, 2008 457  choose_loop_breaker (details,_,_) _loop_sc acc []  simonm committed Dec 02, 1998 458 459 460 461 462 463 464 465  = (details, acc) -- Done choose_loop_breaker loop_bind loop_sc acc (bind : binds) | sc < loop_sc -- Lower score so pick this new one = choose_loop_breaker bind sc (loop_bind : acc) binds | otherwise -- No lower so don't pick it = choose_loop_breaker loop_bind loop_sc (bind : acc) binds  sof committed May 19, 1997 466  where  simonm committed Dec 02, 1998 467 468  sc = score bind  simonpj@microsoft.com committed Oct 05, 2006 469  score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker  simonpj@microsoft.com committed Oct 29, 2007 470  score ((bndr, rhs, _), _, _)  Simon Marlow committed Oct 09, 2007 471 472 473  | workerExists (idWorkerInfo bndr) = 10 -- Note [Worker inline loop]  simonpj committed Aug 01, 2000 474 475 476 477 478 479 480  | exprIsTrivial rhs = 4 -- Practically certain to be inlined -- Used to have also: && not (isExportedId bndr) -- But I found this sometimes cost an extra iteration when we have -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } -- where df is the exported dictionary. Then df makes a really -- bad choice for loop breaker  Simon Marlow committed Oct 09, 2007 481 482  | is_con_app rhs = 2 -- Data types help with cases -- Note [conapp]  simonpj committed Aug 01, 2000 483   Simon Marlow committed Oct 09, 2007 484 485  | inlineCandidate bndr rhs = 1 -- Likely to be inlined -- Note [Inline candidates]  simonpj committed Aug 01, 2000 486   simonm committed Dec 02, 1998 487 488  | otherwise = 0  simonpj committed May 18, 1999 489  inlineCandidate :: Id -> CoreExpr -> Bool  twanvl committed Jan 26, 2008 490 491  inlineCandidate _ (Note InlineMe _) = True inlineCandidate id _ = isOneOcc (idOccInfo id)  simonm committed Dec 02, 1998 492   Simon Marlow committed Oct 09, 2007 493 494 495 496 497  -- Note [conapp] -- -- It's really really important to inline dictionaries. Real -- example (the Enum Ordering instance from GHC.Base): --  sof committed May 19, 1997 498 499 500 501 502 503 504  -- rec f = \ x -> case d of (p,q,r) -> p x -- g = \ x -> case d of (p,q,r) -> q x -- d = (v, f, g) -- -- Here, f and g occur just once; but we can't inline them into d. -- On the other hand we *could* simplify those case expressions if -- we didn't stupidly choose d as the loop breaker.  simonm committed Dec 02, 1998 505  -- But we won't because constructor args are marked "Many".  Simon Marlow committed Oct 09, 2007 506 507  -- Inlining dictionaries is really essential to unravelling -- the loops in static numeric dictionaries, see GHC.Float.  sof committed May 19, 1997 508   simonpj@microsoft.com committed Nov 29, 2006 509  -- Cheap and cheerful; the simplifer moves casts out of the way  simonpj@microsoft.com committed Dec 06, 2006 510 511 512 513  -- The lambda case is important to spot x = /\a. C (f a) -- which comes up when C is a dictionary constructor and -- f is a default method. -- Example: the instance for Show (ST s a) in GHC.ST  simonpj@microsoft.com committed Jun 29, 2007 514 515 516  -- -- However we *also* treat (\x. C p q) as a con-app-like thing, -- Note [Closure conversion]  simonpj@microsoft.com committed Nov 29, 2006 517 518  is_con_app (Var v) = isDataConWorkId v is_con_app (App f _) = is_con_app f  twanvl committed Jan 26, 2008 519  is_con_app (Lam _ e) = is_con_app e  simonpj@microsoft.com committed Nov 29, 2006 520  is_con_app (Note _ e) = is_con_app e  twanvl committed Jan 26, 2008 521  is_con_app _ = False  simonpj@microsoft.com committed Oct 04, 2006 522   simonpj@microsoft.com committed Oct 29, 2007 523 524 525 526 makeLoopBreaker :: Bool -> Id -> Id -- Set the loop-breaker flag -- See Note [Weak loop breakers] makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)  partain committed Jan 08, 1996 527 528 \end{code}  Simon Marlow committed Oct 09, 2007 529 Note [Worker inline loop]  530 ~~~~~~~~~~~~~~~~~~~~~~~~  Simon Marlow committed Oct 09, 2007 531 532 533 Never choose a wrapper as the loop breaker! Because wrappers get auto-generated inlinings when importing, and that can lead to an infinite inlining loop. For example:  534 535 536 537 538  rec { $wfoo x = ....foo x.... {-loop brk-} foo x = ...$wfoo x... }  Simon Marlow committed Oct 09, 2007 539 540 541 542 543 544 545 546  The interface file sees the unfolding for $wfoo, and sees that foo is strict (and hence it gets an auto-generated wrapper). Result: an infinite inlining in the importing scope. So be a bit careful if you change this. A good example is Tree.repTree in nofib/spectral/minimax. If the repTree wrapper is chosen as the loop breaker then compiling Game.hs goes into an infinite loop (this happened when we gave is_con_app a lower score than inline candidates).  547   simonpj@microsoft.com committed Jun 29, 2007 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 Note [Closure conversion] ~~~~~~~~~~~~~~~~~~~~~~~~~ We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. The immediate motivation came from the result of a closure-conversion transformation which generated code like this: data Clo a b = forall c. Clo (c -> a -> b) c ($:) :: Clo a b -> a -> b Clo f env $: x = f env x rec { plus = Clo plus1 () ; plus1 _ n = Clo plus2 n ; plus2 Zero n = n ; plus2 (Succ m) n = Succ (plus$: m \$: n) } If we inline 'plus' and 'plus1', everything unravels nicely. But if we choose 'plus1' as the loop breaker (which is entirely possible otherwise), the loop does not unravel nicely.  partain committed Jan 08, 1996 571 572 573 574 575 576 577 @occAnalRhs@ deals with the question of bindings where the Id is marked by an INLINE pragma. For these we record that anything which occurs in its RHS occurs many times. This pessimistically assumes that ths inlined binder also occurs many times in its scope, but if it doesn't we'll catch it next time round. At worst this costs an extra simplifier pass. ToDo: try using the occurrence info for the inline'd binder.  sof committed May 19, 1997 578 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.  simonm committed Dec 02, 1998 579 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.  sof committed May 19, 1997 580   simonpj committed Mar 08, 1998 581   partain committed Jan 08, 1996 582 583 \begin{code} occAnalRhs :: OccEnv  sof committed May 19, 1997 584  -> Id -> CoreExpr -- Binder and rhs  simonpj committed Nov 20, 2002 585 586  -- For non-recs the binder is alrady tagged -- with occurrence info  simonm committed Dec 02, 1998 587  -> (UsageDetails, CoreExpr)  partain committed Jan 08, 1996 588 589  occAnalRhs env id rhs  simonpj@microsoft.com committed Oct 05, 2006 590  = occAnal ctxt rhs  partain committed Jan 08, 1996 591  where  simonpj committed Nov 20, 2002 592  ctxt | certainly_inline id = env  simonmar committed Apr 05, 2005 593  | otherwise = rhsCtxt  simonpj committed Nov 20, 2002 594 595  -- Note that we generally use an rhsCtxt. This tells the occ anal n -- that it's looking at an RHS, which has an effect in occAnalApp  simonpj committed Oct 31, 2001 596 597 598 599 600  -- -- But there's a problem. Consider -- x1 = a0 : [] -- x2 = a1 : x1 -- x3 = a2 : x2  simonpj committed Nov 20, 2002 601  -- g = f x3  simonpj committed Oct 31, 2001 602 603 604 605 606  -- First time round, it looks as if x1 and x2 occur as an arg of a -- let-bound constructor ==> give them a many-occurrence. -- But then x3 is inlined (unconditionally as it happens) and -- next time round, x2 will be, and the next time round x1 will be -- Result: multiple simplifier iterations. Sigh.  simonpj committed Nov 20, 2002 607 608 609  -- Crude solution: use rhsCtxt for things that occur just once... certainly_inline id = case idOccInfo id of  simonmar committed Aug 03, 2005 610  OneOcc in_lam one_br _ -> not in_lam && one_br  twanvl committed Jan 26, 2008 611  _ -> False  simonpj@microsoft.com committed Oct 05, 2006 612 613 614 615 616 \end{code} \begin{code}  simonpj committed Mar 07, 2005 617 618 619 620 621 addRuleUsage :: UsageDetails -> Id -> UsageDetails -- Add the usage from RULES in Id to the usage addRuleUsage usage id = foldVarSet add usage (idRuleVars id) where  simonpj@microsoft.com committed Oct 05, 2006 622  add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info  simonpj committed May 18, 1999 623 624  -- (i.e manyOcc) because many copies -- of the specialised thing can appear  partain committed Jan 08, 1996 625 626 627 628 629 630 \end{code} Expressions ~~~~~~~~~~~ \begin{code} occAnal :: OccEnv  partain committed Mar 19, 1996 631  -> CoreExpr  partain committed Apr 05, 1996 632  -> (UsageDetails, -- Gives info only about the "interesting" Ids  simonm committed Dec 02, 1998 633  CoreExpr)  partain committed Jan 08, 1996 634   twanvl committed Jan 26, 2008 635 occAnal _ (Type t) = (emptyDetails, Type t)  simonmar committed Aug 03, 2005 636 occAnal env (Var v) = (mkOneOcc env v False, Var v)  simonpj committed May 18, 1999 637 638  -- At one stage, I gathered the idRuleVars for v here too, -- which in a way is the right thing to do.  simonpj committed Apr 28, 2005 639  -- Btu that went wrong right after specialisation, when  simonpj committed May 18, 1999 640 641 642  -- the *occurrences* of the overloaded function didn't have any -- rules in them, so the *specialised* versions looked as if they -- weren't used at all.  partain committed Jul 15, 1996 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 \end{code} We regard variables that occur as constructor arguments as "dangerousToDup": \begin{verbatim} module A where f x = let y = expensive x in let z = (True,y) in (case z of {(p,q)->q}, case z of {(p,q)->q}) \end{verbatim} We feel free to duplicate the WHNF (True,y), but that means that y may be duplicated thereby. If we aren't careful we duplicate the (expensive x) call! Constructors are rather like lambdas in this way. \begin{code}  twanvl committed Jan 26, 2008 661 occAnal _ expr@(Lit _) = (emptyDetails, expr)  simonm committed Dec 02, 1998 662 \end{code}  partain committed Jan 08, 1996 663   simonm committed Dec 02, 1998 664 \begin{code}  simonpj committed May 18, 1999 665 666 667 668 669 occAnal env (Note InlineMe body) = case occAnal env body of { (usage, body') -> (mapVarEnv markMany usage, Note InlineMe body') }  twanvl committed Jan 26, 2008 670 occAnal env (Note note@(SCC _) body)  simonm committed Dec 02, 1998 671 672 673  = case occAnal env body of { (usage, body') -> (mapVarEnv markInsideSCC usage, Note note body') }  partain committed Apr 30, 1996 674   simonpj committed Mar 19, 1998 675 occAnal env (Note note body)  simonm committed Dec 02, 1998 676 677 678  = case occAnal env body of { (usage, body') -> (usage, Note note body') }  chak@cse.unsw.edu.au. committed Sep 15, 2006 679 680 681  occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') ->  simonpj@microsoft.com committed Nov 01, 2006 682 683 684 685  (markRhsUds env True usage, Cast expr' co) -- If we see let x = y cast co -- then mark y as 'Many' so that we don't -- immediately inline y again.  chak@cse.unsw.edu.au. committed Sep 15, 2006 686  }  simonm committed Dec 02, 1998 687 \end{code}  partain committed Jan 08, 1996 688   simonm committed Dec 02, 1998 689 \begin{code}  twanvl committed Jan 26, 2008 690 691 occAnal env app@(App _ _) = occAnalApp env (collectArgs app)  simonpj committed May 18, 1999 692   simonm committed Mar 17, 1999 693 694 695 696 -- Ignore type variables altogether -- (a) occurrences inside type lambdas only not marked as InsideLam -- (b) type variables not in environment  twanvl committed Jan 26, 2008 697 occAnal env (Lam x body) | isTyVar x  simonm committed Mar 17, 1999 698 699 700  = case occAnal env body of { (body_usage, body') -> (body_usage, Lam x body') }  partain committed Mar 19, 1996 701   partain committed Jul 15, 1996 702 703 704 705 706 -- For value lambdas we do a special hack. Consider -- (\x. \y. ...x...) -- If we did nothing, x is used inside the \y, so would be marked -- as dangerous to dup. But in the common case where the abstraction -- is applied to two arguments this is over-pessimistic.  simonm committed Dec 02, 1998 707 708 709 710 711 -- So instead, we just mark each binder with its occurrence -- info in the *body* of the multiple lambda. -- Then, the simplifier is careful when partially applying lambdas. occAnal env expr@(Lam _ _)  simonpj committed Sep 26, 2001 712  = case occAnal env_body body of { (body_usage, body') ->  simonm committed Dec 02, 1998 713 714  let (final_usage, tagged_binders) = tagBinders body_usage binders  simonpj committed Sep 17, 1999 715 716 717 718  -- URGH! Sept 99: we don't seem to be able to use binders' here, because -- we get linear-typed things in the resulting program that we can't handle yet. -- (e.g. PrelShow) TODO  simonpj committed May 18, 1999 719 720 721 722  really_final_usage = if linear then final_usage else mapVarEnv markInsideLam final_usage  simonm committed Dec 02, 1998 723  in  simonpj committed May 18, 1999 724  (really_final_usage,  simonm committed Dec 02, 1998 725  mkLams tagged_binders body') }  partain committed Jan 08, 1996 726  where  simonmar committed Apr 05, 2005 727 728 729 730 731  env_body = vanillaCtxt -- Body is (no longer) an RhsContext (binders, body) = collectBinders expr binders' = oneShotGroup env binders linear = all is_one_shot binders' is_one_shot b = isId b && isOneShotBndr b  simonm committed Dec 02, 1998 732   simonpj committed Sep 30, 2004 733 occAnal env (Case scrut bndr ty alts)  simonpj@microsoft.com committed Aug 14, 2006 734 735  = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->  simonm committed Dec 02, 1998 736 737  let alts_usage = foldr1 combineAltsUsageDetails alts_usage_s  simonpj committed Nov 01, 1999 738 739  alts_usage' = addCaseBndrUsage alts_usage (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr  simonpj@microsoft.com committed Oct 05, 2006 740  total_usage = scrut_usage +++ alts_usage1  simonm committed Dec 02, 1998 741  in  simonpj committed Sep 30, 2004 742  total_usage seq (total_usage, Case scrut' tagged_bndr ty alts') }}  partain committed Jan 08, 1996 743  where  simonpj committed Nov 01, 1999 744 745 746 747 748 749 750 751 752 753 754  -- The case binder gets a usage of either "many" or "dead", never "one". -- Reason: we like to inline single occurrences, to eliminate a binding, -- but inlining a case binder *doesn't* eliminate a binding. -- We *don't* want to transform -- case x of w { (p,q) -> f w } -- into -- case x of w { (p,q) -> f (p,q) } addCaseBndrUsage usage = case lookupVarEnv usage bndr of Nothing -> usage Just occ -> extendVarEnv usage bndr (markMany occ)  simonpj@microsoft.com committed Aug 14, 2006 755 756 757 758  alt_env = setVanillaCtxt env -- Consider x = case v of { True -> (p,q); ... } -- Then it's fine to inline p and q  simonmar committed Aug 03, 2005 759 760 761  occ_anal_scrut (Var v) (alt1 : other_alts) | not (null other_alts) || not (isDefaultAlt alt1) = (mkOneOcc env v True, Var v)  twanvl committed Jan 26, 2008 762  occ_anal_scrut scrut _alts = occAnal vanillaCtxt scrut  simonmar committed Aug 03, 2005 763 764  -- No need for rhsCtxt  partain committed Mar 19, 1996 765 occAnal env (Let bind body)  simonmar committed Apr 05, 2005 766  = case occAnal env body of { (body_usage, body') ->  simonpj committed Mar 14, 1997 767  case occAnalBind env bind body_usage of { (final_usage, new_binds) ->  simonm committed Dec 02, 1998 768  (final_usage, mkLets new_binds body') }}  simonpj committed May 18, 1999 769   twanvl committed Jan 26, 2008 770 771 occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr]) occAnalArgs _env args  simonpj committed Jun 08, 1999 772  = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->  simonpj@microsoft.com committed Oct 05, 2006 773  (foldr (+++) emptyDetails arg_uds_s, args')}  simonpj committed Jun 08, 1999 774  where  simonmar committed Apr 05, 2005 775  arg_env = vanillaCtxt  partain committed Jan 08, 1996 776 777 \end{code}  simonpj committed May 18, 1999 778 779 780 781 Applications are dealt with specially because we want the "build hack" to work. \begin{code}  twanvl committed Jan 26, 2008 782 783 784 785 occAnalApp :: OccEnv -> (Expr CoreBndr, [Arg CoreBndr]) -> (UsageDetails, Expr CoreBndr) occAnalApp env (Var fun, args)  simonpj committed May 18, 1999 786 787  = case args_stuff of { (args_uds, args') -> let  simonpj@microsoft.com committed Nov 01, 2006 788  final_args_uds = markRhsUds env is_pap args_uds  simonpj committed May 18, 1999 789  in  simonpj@microsoft.com committed Oct 05, 2006 790  (fun_uds +++ final_args_uds, mkApps (Var fun) args') }  simonpj committed May 18, 1999 791 792  where fun_uniq = idUnique fun  simonmar committed Aug 03, 2005 793  fun_uds = mkOneOcc env fun (valArgCount args > 0)  simonpj@microsoft.com committed Nov 01, 2006 794  is_pap = isDataConWorkId fun || valArgCount args < idArity fun  simonpj@microsoft.com committed Aug 14, 2006 795 796  -- Hack for build, fold, runST  simonpj committed May 18, 1999 797 798 799  args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args  simonpj committed Sep 26, 2001 800 801 802 803 804 805 806 807 808 809  | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args -- (foldr k z xs) may call k many times, but it never -- shares a partial application of k; hence [False,True] -- This means we can optimise -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs -- by floating in the v | otherwise = occAnalArgs env args  twanvl committed Jan 26, 2008 810 occAnalApp env (fun, args)  simonpj committed Sep 26, 2001 811 812 813 814 815 816 817 818 819  = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') -> -- The addAppCtxt is a bit cunning. One iteration of the simplifier -- often leaves behind beta redexs like -- (\x y -> e) a1 a2 -- Here we would like to mark x,y as one-shot, and treat the whole -- thing much like a let. We do this by pushing some True items -- onto the context stack. case occAnalArgs env args of { (args_uds, args') ->  simonpj committed May 18, 1999 820  let  simonpj@microsoft.com committed Oct 05, 2006 821  final_uds = fun_uds +++ args_uds  simonpj committed May 18, 1999 822 823 824  in (final_uds, mkApps fun' args') }}  simonpj@microsoft.com committed Nov 01, 2006 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841  markRhsUds :: OccEnv -- Check if this is a RhsEnv -> Bool -- and this is true -> UsageDetails -- The do markMany on this -> UsageDetails -- We mark the free vars of the argument of a constructor or PAP -- as "many", if it is the RHS of a let(rec). -- This means that nothing gets inlined into a constructor argument -- position, which is what we want. Typically those constructor -- arguments are just variables, or trivial expressions. -- -- This is the *whole point* of the isRhsEnv predicate markRhsUds env is_pap arg_uds | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds | otherwise = arg_uds  simonpj committed Sep 26, 2001 842 843 844 845 appSpecial :: OccEnv -> Int -> CtxtTy -- Argument number, and context to use for it -> [CoreExpr] -> (UsageDetails, [CoreExpr])  simonpj committed May 18, 1999 846 847 848 appSpecial env n ctxt args = go n args where  simonmar committed Apr 05, 2005 849  arg_env = vanillaCtxt  simonpj committed Sep 26, 2001 850   twanvl committed Jan 26, 2008 851  go _ [] = (emptyDetails, []) -- Too few args  simonpj committed May 18, 1999 852 853  go 1 (arg:args) -- The magic arg  simonpj committed Sep 26, 2001 854 855  = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') -> case occAnalArgs env args of { (args_uds, args') ->  simonpj@microsoft.com committed Oct 05, 2006 856  (arg_uds +++ args_uds, arg':args') }}  simonpj committed May 18, 1999 857 858  go n (arg:args)  simonpj committed Sep 26, 2001 859  = case occAnal arg_env arg of { (arg_uds, arg') ->  simonpj committed May 18, 1999 860  case go (n-1) args of { (args_uds, args') ->  simonpj@microsoft.com committed Oct 05, 2006 861  (arg_uds +++ args_uds, arg':args') }}  simonpj committed May 18, 1999 862 863 864 \end{code}  partain committed Jan 08, 1996 865 866 Case alternatives ~~~~~~~~~~~~~~~~~  simonpj committed Sep 26, 2001 867 868 869 870 871 872 873 874 If the case binder occurs at all, the other binders effectively do too. For example case e of x { (a,b) -> rhs } is rather like let x = (a,b) in rhs If e turns out to be (e1,e2) we indeed get something like let a = e1; b = e2; x = (a,b) in rhs  simonpj@microsoft.com committed Aug 16, 2006 875 876 877 878 Note [Aug 06]: I don't think this is necessary any more, and it helpe to know when binders are unused. See esp the call to isDeadBinder in Simplify.mkDupableAlt  partain committed Jan 08, 1996 879 \begin{code}  twanvl committed Jan 26, 2008 880 881 882 883 884 occAnalAlt :: OccEnv -> CoreBndr -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo) occAnalAlt env _case_bndr (con, bndrs, rhs)  simonmar committed Apr 05, 2005 885  = case occAnal env rhs of { (rhs_usage, rhs') ->  simonm committed Dec 02, 1998 886 887  let (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs  simonpj@microsoft.com committed Aug 16, 2006 888 889  final_bndrs = tagged_bndrs -- See Note [Aug06] above {-  simonpj committed Sep 26, 2001 890 891 892 893  final_bndrs | case_bndr elemVarEnv final_usage = bndrs | otherwise = tagged_bndrs -- Leave the binders untagged if the case -- binder occurs at all; see note above  simonpj@microsoft.com committed Aug 16, 2006 894 -}  simonm committed Dec 02, 1998 895  in  simonpj committed Sep 26, 2001 896  (final_usage, (con, final_bndrs, rhs')) }  partain committed Jan 08, 1996 897 \end{code}  simonpj committed Mar 09, 1998 898 899 900 901  %************************************************************************ %* *  simonpj committed Sep 26, 2001 902 \subsection[OccurAnal-types]{OccEnv}  simonpj committed Mar 09, 1998 903 904 905 906 %* * %************************************************************************ \begin{code}  simonpj committed Sep 26, 2001 907 data OccEnv  simonmar committed Apr 05, 2005 908  = OccEnv OccEncl -- Enclosing context information  simonpj committed Sep 26, 2001 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923  CtxtTy -- Tells about linearity -- OccEncl is used to control whether to inline into constructor arguments -- For example: -- x = (p,q) -- Don't inline p or q -- y = /\a -> (p a, q a) -- Still don't inline p or q -- z = f (p,q) -- Do inline p,q; it may make a rule fire -- So OccEncl tells enought about the context to know what to do when -- we encounter a contructor application or PAP. data OccEncl = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda -- Don't inline into constructor args here | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. -- Do inline into constructor args here  simonpj committed Mar 09, 1998 924   simonpj committed May 18, 1999 925 926 927 928 929 930 931 932 933 type CtxtTy = [Bool] -- [] No info -- -- True:ctxt Analysing a function-valued expression that will be -- applied just once -- -- False:ctxt Analysing a function-valued expression that may -- be applied many times; but when it is, -- the CtxtTy inside applies  simonpj committed Mar 09, 1998 934   simonmar committed Apr 05, 2005 935 936 initOccEnv :: OccEnv initOccEnv = OccEnv OccRhs []  simonpj committed Mar 09, 1998 937   twanvl committed Jan 26, 2008 938 vanillaCtxt :: OccEnv  simonmar committed Apr 05, 2005 939 vanillaCtxt = OccEnv OccVanilla []  twanvl committed Jan 26, 2008 940 941  rhsCtxt :: OccEnv  simonmar committed Apr 05, 2005 942 rhsCtxt = OccEnv OccRhs []  simonpj committed Mar 09, 1998 943   twanvl committed Jan 26, 2008 944 isRhsEnv :: OccEnv -> Bool  simonmar committed Apr 05, 2005 945 946 isRhsEnv (OccEnv OccRhs _) = True isRhsEnv (OccEnv OccVanilla _) = False  simonpj committed Mar 09, 1998 947   simonpj@microsoft.com committed Aug 14, 2006 948 949 950 951 setVanillaCtxt :: OccEnv -> OccEnv setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty setVanillaCtxt other_env = other_env  simonpj committed May 18, 1999 952 setCtxt :: OccEnv -> CtxtTy -> OccEnv  simonmar committed Apr 05, 2005 953 setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt  simonpj committed Sep 17, 1999 954   simonmar committed Apr 05, 2005 955 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]  simonpj committed Sep 17, 1999 956 957 958 959 960  -- The result binders have one-shot-ness set that they might not have had originally. -- This happens in (build (\cn -> e)). Here the occurrence analyser -- linearity context knows that c,n are one-shot, and it records that fact in -- the binder. This is useful to guide subsequent float-in/float-out tranformations  twanvl committed Jan 26, 2008 961 oneShotGroup (OccEnv _encl ctxt) bndrs  simonmar committed Apr 05, 2005 962  = go ctxt bndrs []  simonpj committed Jul 06, 1999 963  where  twanvl committed Jan 26, 2008 964  go _ [] rev_bndrs = reverse rev_bndrs  simonpj committed Sep 17, 1999 965 966 967 968 969 970 971 972 973  go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs | isId bndr = go ctxt bndrs (bndr':rev_bndrs) where bndr' | lin_ctxt = setOneShotLambda bndr | otherwise = bndr go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)  twanvl committed Jan 26, 2008 974 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv  simonmar committed Apr 05, 2005 975 976 addAppCtxt (OccEnv encl ctxt) args = OccEnv encl (replicate (valArgCount args) True ++ ctxt)  simonpj committed Sep 26, 2001 977 978 979 980 981 982 983 \end{code} %************************************************************************ %* * \subsection[OccurAnal-types]{OccEnv} %* * %************************************************************************  simonpj committed Jun 08, 1999 984   simonpj committed Sep 26, 2001 985 \begin{code}  simonpj committed Jan 29, 2001 986 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage  simonpj committed Mar 09, 1998 987   simonpj@microsoft.com committed Oct 05, 2006 988 (+++), combineAltsUsageDetails  simonpj committed Mar 09, 1998 989 990  :: UsageDetails -> UsageDetails -> UsageDetails  simonpj@microsoft.com committed Oct 05, 2006 991 (+++) usage1 usage2  simonpj committed Jan 29, 2001 992  = plusVarEnv_C addOccInfo usage1 usage2  simonpj committed Mar 09, 1998 993 994  combineAltsUsageDetails usage1 usage2  simonpj committed Jan 29, 2001 995  = plusVarEnv_C orOccInfo usage1 usage2  simonpj committed Mar 09, 1998 996   simonpj committed Jan 29, 2001 997 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails  simonpj committed Mar 09, 1998 998 addOneOcc usage id info  simonpj committed Jan 29, 2001 999  = plusVarEnv_C addOccInfo usage (unitVarEnv id info)  simonpj committed Mar 09, 1998 1000 1001  -- ToDo: make this more efficient  twanvl committed Jan 26, 2008 1002 emptyDetails :: UsageDetails  simonm committed Dec 02, 1998 1003 emptyDetails = (emptyVarEnv :: UsageDetails)  simonpj committed Mar 09, 1998 1004   simonpj committed Jan 28, 1999 1005 usedIn :: Id -> UsageDetails -> Bool  simonpj committed May 18, 1999 1006 v usedIn details = isExportedId v || v elemVarEnv details  simonpj committed Jan 28, 1999 1007   simonpj@microsoft.com committed Oct 05, 2006 1008 1009 type IdWithOccInfo = Id  simonpj committed Mar 09, 1998 1010 1011 1012 tagBinders :: UsageDetails -- Of scope -> [Id] -- Binders -> (UsageDetails, -- Details with binders removed  simonm committed Dec 02, 1998 1013 1014 1015 1016 1017  [IdWithOccInfo]) -- Tagged binders tagBinders usage binders = let usage' = usage delVarEnvList binders  simonpj committed Nov 01, 1999 1018  uss = map (setBinderOcc usage) binders  simonm committed Dec 02, 1998 1019 1020 1021  in usage' seq (usage', uss)  simonpj committed Mar 09, 1998 1022 1023 1024 tagBinder :: UsageDetails -- Of scope -> Id -- Binders -> (UsageDetails, -- Details with binders removed  simonm committed Dec 02, 1998 1025 1026 1027 1028 1029  IdWithOccInfo) -- Tagged binders tagBinder usage binder = let usage' = usage delVarEnv binder  simonpj committed Nov 01, 1999 1030  binder' = setBinderOcc usage binder  simonm committed Dec 02, 1998 1031 1032 1033  in usage' seq (usage', binder')  simonpj committed Nov 01, 1999 1034 1035 1036 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr setBinderOcc usage bndr | isTyVar bndr = bndr  simonpj committed Jan 29, 2001 1037 1038  | isExportedId bndr = case idOccInfo bndr of NoOccInfo -> bndr  twanvl committed Jan 26, 2008 1039  _ -> setIdOccInfo bndr NoOccInfo  simonpj committed Jan 29, 2001 1040 1041 1042  -- Don't use local usage info for visible-elsewhere things -- BUT *do* erase any IAmALoopBreaker annotation, because we're -- about to re-generate it and it shouldn't be "sticky"  simonpj committed Nov 01, 1999 1043   simonpj committed Jan 29, 2001 1044  | otherwise = setIdOccInfo bndr occ_info  simonm committed Dec 02, 1998 1045  where  simonpj committed Jan 29, 2001 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056  occ_info = lookupVarEnv usage bndr orElse IAmDead \end{code} %************************************************************************ %* * \subsection{Operations over OccInfo} %* * %************************************************************************ \begin{code}  simonmar committed Aug 03, 2005 1057 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails  twanvl committed Jan 26, 2008 1058 mkOneOcc _env id int_cxt  simonmar committed Aug 03, 2005 1059 1060  | isLocalId id = unitVarEnv id (OneOcc False True int_cxt) | otherwise = emptyDetails  simonpj committed Jan 29, 2001 1061 1062 1063 1064  markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo markMany IAmDead = IAmDead  twanvl committed Jan 26, 2008 1065 markMany _ = NoOccInfo  simonpj committed Jan 29, 2001 1066 1067 1068  markInsideSCC occ = markMany occ  simonmar committed Aug 03, 2005 1069 1070 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt markInsideLam occ = occ  simonpj committed Jan 29, 2001 1071 1072 1073  addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo  simonpj@microsoft.com committed Oct 03, 2006 1074 1075 addOccInfo IAmDead info2 = info2 addOccInfo info1 IAmDead = info1  twanvl committed Jan 26, 2008 1076 addOccInfo _ _ = NoOccInfo  simonpj committed Jan 29, 2001 1077 1078 1079 1080 1081 1082  -- (orOccInfo orig new) is used -- when combining occurrence info from branches of a case orOccInfo IAmDead info2 = info2 orOccInfo info1 IAmDead = info1  twanvl committed Jan 26, 2008 1083 1084 orOccInfo (OneOcc in_lam1 _ int_cxt1) (OneOcc in_lam2 _ int_cxt2)  simonpj committed Jan 30, 2001 1085 1086  = OneOcc (in_lam1 || in_lam2) False -- False, because it occurs in both branches  simonmar committed Aug 03, 2005 1087  (int_cxt1 && int_cxt2)  twanvl committed Jan 26, 2008 1088 orOccInfo _ _ = NoOccInfo  simonm committed Dec 02, 1998 1089 \end{code}