PageRenderTime 69ms CodeModel.GetById 27ms RepoModel.GetById 1ms app.codeStats 0ms

/compiler/simplCore/OccurAnal.lhs

https://github.com/crdueck/ghc
Haskell | 1871 lines | 1298 code | 332 blank | 241 comment | 99 complexity | 02e865b7738e52239e1b418a1c0c111f MD5 | raw file
  1. %
  2. % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
  3. %
  4. %************************************************************************
  5. %* *
  6. \section[OccurAnal]{Occurrence analysis pass}
  7. %* *
  8. %************************************************************************
  9. The occurrence analyser re-typechecks a core expression, returning a new
  10. core expression with (hopefully) improved usage information.
  11. \begin{code}
  12. {-# LANGUAGE BangPatterns #-}
  13. module OccurAnal (
  14. occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap
  15. ) where
  16. #include "HsVersions.h"
  17. import CoreSyn
  18. import CoreFVs
  19. import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp )
  20. import Id
  21. import Name( localiseName )
  22. import BasicTypes
  23. import Module( Module )
  24. import Coercion
  25. import VarSet
  26. import VarEnv
  27. import Var
  28. import Demand ( argOneShots, argsOneShots )
  29. import Maybes ( orElse )
  30. import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
  31. import Unique
  32. import UniqFM
  33. import Util
  34. import Outputable
  35. import FastString
  36. import Data.List
  37. \end{code}
  38. %************************************************************************
  39. %* *
  40. \subsection[OccurAnal-main]{Counting occurrences: main function}
  41. %* *
  42. %************************************************************************
  43. Here's the externally-callable interface:
  44. \begin{code}
  45. occurAnalysePgm :: Module -- Used only in debug output
  46. -> (Activation -> Bool)
  47. -> [CoreRule] -> [CoreVect] -> VarSet
  48. -> CoreProgram -> CoreProgram
  49. occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds
  50. | isEmptyVarEnv final_usage
  51. = binds'
  52. | otherwise -- See Note [Glomming]
  53. = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)
  54. 2 (ppr final_usage ) )
  55. [Rec (flattenBinds binds')]
  56. where
  57. (final_usage, binds') = go (initOccEnv active_rule) binds
  58. initial_uds = addIdOccs emptyDetails
  59. (rulesFreeVars imp_rules `unionVarSet`
  60. vectsFreeVars vects `unionVarSet`
  61. vectVars)
  62. -- The RULES and VECTORISE declarations keep things alive! (For VECTORISE declarations,
  63. -- we only get them *until* the vectoriser runs. Afterwards, these dependencies are
  64. -- reflected in 'vectors' — see Note [Vectorisation declarations and occurences].)
  65. -- Note [Preventing loops due to imported functions rules]
  66. imp_rules_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv
  67. [ mapVarEnv (const maps_to) (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule)
  68. | imp_rule <- imp_rules
  69. , let maps_to = exprFreeIds (ru_rhs imp_rule)
  70. `delVarSetList` ru_bndrs imp_rule
  71. , arg <- ru_args imp_rule ]
  72. go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
  73. go _ []
  74. = (initial_uds, [])
  75. go env (bind:binds)
  76. = (final_usage, bind' ++ binds')
  77. where
  78. (bs_usage, binds') = go env binds
  79. (final_usage, bind') = occAnalBind env env imp_rules_edges bind bs_usage
  80. occurAnalyseExpr :: CoreExpr -> CoreExpr
  81. -- Do occurrence analysis, and discard occurence info returned
  82. occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap
  83. occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr
  84. occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap
  85. occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr
  86. occurAnalyseExpr' enable_binder_swap expr
  87. = snd (occAnal env expr)
  88. where
  89. env = (initOccEnv all_active_rules) {occ_binder_swap = enable_binder_swap}
  90. -- To be conservative, we say that all inlines and rules are active
  91. all_active_rules = \_ -> True
  92. \end{code}
  93. %************************************************************************
  94. %* *
  95. \subsection[OccurAnal-main]{Counting occurrences: main function}
  96. %* *
  97. %************************************************************************
  98. Bindings
  99. ~~~~~~~~
  100. \begin{code}
  101. occAnalBind :: OccEnv -- The incoming OccEnv
  102. -> OccEnv -- Same, but trimmed by (binderOf bind)
  103. -> IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs
  104. -> CoreBind
  105. -> UsageDetails -- Usage details of scope
  106. -> (UsageDetails, -- Of the whole let(rec)
  107. [CoreBind])
  108. occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage
  109. | isTyVar binder -- A type let; we don't gather usage info
  110. = (body_usage, [NonRec binder rhs])
  111. | not (binder `usedIn` body_usage) -- It's not mentioned
  112. = (body_usage, [])
  113. | otherwise -- It's mentioned in the body
  114. = (body_usage' +++ rhs_usage4, [NonRec tagged_binder rhs'])
  115. where
  116. (body_usage', tagged_binder) = tagBinder body_usage binder
  117. (rhs_usage1, rhs') = occAnalNonRecRhs env tagged_binder rhs
  118. rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder)
  119. rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder)
  120. -- See Note [Rules are extra RHSs] and Note [Rule dependency info]
  121. rhs_usage4 = maybe rhs_usage3 (addIdOccs rhs_usage3) $ lookupVarEnv imp_rules_edges binder
  122. -- See Note [Preventing loops due to imported functions rules]
  123. occAnalBind _ env imp_rules_edges (Rec pairs) body_usage
  124. = foldr occAnalRec (body_usage, []) sccs
  125. -- For a recursive group, we
  126. -- * occ-analyse all the RHSs
  127. -- * compute strongly-connected components
  128. -- * feed those components to occAnalRec
  129. where
  130. bndr_set = mkVarSet (map fst pairs)
  131. sccs :: [SCC (Node Details)]
  132. sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR nodes
  133. nodes :: [Node Details]
  134. nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env imp_rules_edges bndr_set) pairs
  135. \end{code}
  136. Note [Dead code]
  137. ~~~~~~~~~~~~~~~~
  138. Dropping dead code for a cyclic Strongly Connected Component is done
  139. in a very simple way:
  140. the entire SCC is dropped if none of its binders are mentioned
  141. in the body; otherwise the whole thing is kept.
  142. The key observation is that dead code elimination happens after
  143. dependency analysis: so 'occAnalBind' processes SCCs instead of the
  144. original term's binding groups.
  145. Thus 'occAnalBind' does indeed drop 'f' in an example like
  146. letrec f = ...g...
  147. g = ...(...g...)...
  148. in
  149. ...g...
  150. when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in
  151. 'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes
  152. 'AcyclicSCC f', where 'body_usage' won't contain 'f'.
  153. ------------------------------------------------------------
  154. Note [Forming Rec groups]
  155. ~~~~~~~~~~~~~~~~~~~~~~~~~
  156. We put bindings {f = ef; g = eg } in a Rec group if "f uses g"
  157. and "g uses f", no matter how indirectly. We do a SCC analysis
  158. with an edge f -> g if "f uses g".
  159. More precisely, "f uses g" iff g should be in scope whereever f is.
  160. That is, g is free in:
  161. a) the rhs 'ef'
  162. b) or the RHS of a rule for f (Note [Rules are extra RHSs])
  163. c) or the LHS or a rule for f (Note [Rule dependency info])
  164. These conditions apply regardless of the activation of the RULE (eg it might be
  165. inactive in this phase but become active later). Once a Rec is broken up
  166. it can never be put back together, so we must be conservative.
  167. The principle is that, regardless of rule firings, every variale is
  168. always in scope.
  169. * Note [Rules are extra RHSs]
  170. ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  171. A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
  172. keeps the specialised "children" alive. If the parent dies
  173. (because it isn't referenced any more), then the children will die
  174. too (unless they are already referenced directly).
  175. To that end, we build a Rec group for each cyclic strongly
  176. connected component,
  177. *treating f's rules as extra RHSs for 'f'*.
  178. More concretely, the SCC analysis runs on a graph with an edge
  179. from f -> g iff g is mentioned in
  180. (a) f's rhs
  181. (b) f's RULES
  182. These are rec_edges.
  183. Under (b) we include variables free in *either* LHS *or* RHS of
  184. the rule. The former might seems silly, but see Note [Rule
  185. dependency info]. So in Example [eftInt], eftInt and eftIntFB
  186. will be put in the same Rec, even though their 'main' RHSs are
  187. both non-recursive.
  188. * Note [Rule dependency info]
  189. ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  190. The VarSet in a SpecInfo is used for dependency analysis in the
  191. occurrence analyser. We must track free vars in *both* lhs and rhs.
  192. Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.
  193. Why both? Consider
  194. x = y
  195. RULE f x = v+4
  196. Then if we substitute y for x, we'd better do so in the
  197. rule's LHS too, so we'd better ensure the RULE appears to mention 'x'
  198. as well as 'v'
  199. * Note [Rules are visible in their own rec group]
  200. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  201. We want the rules for 'f' to be visible in f's right-hand side.
  202. And we'd like them to be visible in other functions in f's Rec
  203. group. E.g. in Note [Specialisation rules] we want f' rule
  204. to be visible in both f's RHS, and fs's RHS.
  205. This means that we must simplify the RULEs first, before looking
  206. at any of the definitions. This is done by Simplify.simplRecBind,
  207. when it calls addLetIdInfo.
  208. ------------------------------------------------------------
  209. Note [Choosing loop breakers]
  210. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  211. Loop breaking is surprisingly subtle. First read the section 4 of
  212. "Secrets of the GHC inliner". This describes our basic plan.
  213. We avoid infinite inlinings by choosing loop breakers, and
  214. ensuring that a loop breaker cuts each loop.
  215. Fundamentally, we do SCC analysis on a graph. For each recursive
  216. group we choose a loop breaker, delete all edges to that node,
  217. re-analyse the SCC, and iterate.
  218. But what is the graph? NOT the same graph as was used for Note
  219. [Forming Rec groups]! In particular, a RULE is like an equation for
  220. 'f' that is *always* inlined if it is applicable. We do *not* disable
  221. rules for loop-breakers. It's up to whoever makes the rules to make
  222. sure that the rules themselves always terminate. See Note [Rules for
  223. recursive functions] in Simplify.lhs
  224. Hence, if
  225. f's RHS (or its INLINE template if it has one) mentions g, and
  226. g has a RULE that mentions h, and
  227. h has a RULE that mentions f
  228. then we *must* choose f to be a loop breaker. Example: see Note
  229. [Specialisation rules].
  230. In general, take the free variables of f's RHS, and augment it with
  231. all the variables reachable by RULES from those starting points. That
  232. is the whole reason for computing rule_fv_env in occAnalBind. (Of
  233. course we only consider free vars that are also binders in this Rec
  234. group.) See also Note [Finding rule RHS free vars]
  235. Note that when we compute this rule_fv_env, we only consider variables
  236. free in the *RHS* of the rule, in contrast to the way we build the
  237. Rec group in the first place (Note [Rule dependency info])
  238. Note that if 'g' has RHS that mentions 'w', we should add w to
  239. g's loop-breaker edges. More concretely there is an edge from f -> g
  240. iff
  241. (a) g is mentioned in f's RHS `xor` f's INLINE rhs
  242. (see Note [Inline rules])
  243. (b) or h is mentioned in f's RHS, and
  244. g appears in the RHS of an active RULE of h
  245. or a transitive sequence of active rules starting with h
  246. Why "active rules"? See Note [Finding rule RHS free vars]
  247. Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
  248. chosen as a loop breaker, because their RHSs don't mention each other.
  249. And indeed both can be inlined safely.
  250. Note again that the edges of the graph we use for computing loop breakers
  251. are not the same as the edges we use for computing the Rec blocks.
  252. That's why we compute
  253. - rec_edges for the Rec block analysis
  254. - loop_breaker_edges for the loop breaker analysis
  255. * Note [Finding rule RHS free vars]
  256. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  257. Consider this real example from Data Parallel Haskell
  258. tagZero :: Array Int -> Array Tag
  259. {-# INLINE [1] tagZeroes #-}
  260. tagZero xs = pmap (\x -> fromBool (x==0)) xs
  261. {-# RULES "tagZero" [~1] forall xs n.
  262. pmap fromBool <blah blah> = tagZero xs #-}
  263. So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.
  264. However, tagZero can only be inlined in phase 1 and later, while
  265. the RULE is only active *before* phase 1. So there's no problem.
  266. To make this work, we look for the RHS free vars only for
  267. *active* rules. That's the reason for the occ_rule_act field
  268. of the OccEnv.
  269. * Note [Weak loop breakers]
  270. ~~~~~~~~~~~~~~~~~~~~~~~~~
  271. There is a last nasty wrinkle. Suppose we have
  272. Rec { f = f_rhs
  273. RULE f [] = g
  274. h = h_rhs
  275. g = h
  276. ...more...
  277. }
  278. Remember that we simplify the RULES before any RHS (see Note
  279. [Rules are visible in their own rec group] above).
  280. So we must *not* postInlineUnconditionally 'g', even though
  281. its RHS turns out to be trivial. (I'm assuming that 'g' is
  282. not choosen as a loop breaker.) Why not? Because then we
  283. drop the binding for 'g', which leaves it out of scope in the
  284. RULE!
  285. Here's a somewhat different example of the same thing
  286. Rec { g = h
  287. ; h = ...f...
  288. ; f = f_rhs
  289. RULE f [] = g }
  290. Here the RULE is "below" g, but we *still* can't postInlineUnconditionally
  291. g, because the RULE for f is active throughout. So the RHS of h
  292. might rewrite to h = ...g...
  293. So g must remain in scope in the output program!
  294. We "solve" this by:
  295. Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True)
  296. iff g is a "missing free variable" of the Rec group
  297. A "missing free variable" x is one that is mentioned in an RHS or
  298. INLINE or RULE of a binding in the Rec group, but where the
  299. dependency on x may not show up in the loop_breaker_edges (see
  300. note [Choosing loop breakers} above).
  301. A normal "strong" loop breaker has IAmLoopBreaker False. So
  302. Inline postInlineUnconditionally
  303. IAmLoopBreaker False no no
  304. IAmLoopBreaker True yes no
  305. other yes yes
  306. The **sole** reason for this kind of loop breaker is so that
  307. postInlineUnconditionally does not fire. Ugh. (Typically it'll
  308. inline via the usual callSiteInline stuff, so it'll be dead in the
  309. next pass, so the main Ugh is the tiresome complication.)
  310. Note [Rules for imported functions]
  311. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  312. Consider this
  313. f = /\a. B.g a
  314. RULE B.g Int = 1 + f Int
  315. Note that
  316. * The RULE is for an imported function.
  317. * f is non-recursive
  318. Now we
  319. can get
  320. f Int --> B.g Int Inlining f
  321. --> 1 + f Int Firing RULE
  322. and so the simplifier goes into an infinite loop. This
  323. would not happen if the RULE was for a local function,
  324. because we keep track of dependencies through rules. But
  325. that is pretty much impossible to do for imported Ids. Suppose
  326. f's definition had been
  327. f = /\a. C.h a
  328. where (by some long and devious process), C.h eventually inlines to
  329. B.g. We could only spot such loops by exhaustively following
  330. unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)
  331. f.
  332. Note that RULES for imported functions are important in practice; they
  333. occur a lot in the libraries.
  334. We regard this potential infinite loop as a *programmer* error.
  335. It's up the programmer not to write silly rules like
  336. RULE f x = f x
  337. and the example above is just a more complicated version.
  338. Note [Preventing loops due to imported functions rules]
  339. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  340. Consider:
  341. import GHC.Base (foldr)
  342. {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}
  343. filter p xs = build (\c n -> foldr (filterFB c p) n xs)
  344. filterFB c p = ...
  345. f = filter p xs
  346. Note that filter is not a loop-breaker, so what happens is:
  347. f = filter p xs
  348. = {inline} build (\c n -> foldr (filterFB c p) n xs)
  349. = {inline} foldr (filterFB (:) p) [] xs
  350. = {RULE} filter p xs
  351. We are in an infinite loop.
  352. A more elaborate example (that I actually saw in practice when I went to
  353. mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:
  354. {-# LANGUAGE RankNTypes #-}
  355. module GHCList where
  356. import Prelude hiding (filter)
  357. import GHC.Base (build)
  358. {-# INLINABLE filter #-}
  359. filter :: (a -> Bool) -> [a] -> [a]
  360. filter p [] = []
  361. filter p (x:xs) = if p x then x : filter p xs else filter p xs
  362. {-# NOINLINE [0] filterFB #-}
  363. filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b
  364. filterFB c p x r | p x = x `c` r
  365. | otherwise = r
  366. {-# RULES
  367. "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr
  368. (filterFB c p) n xs)
  369. "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p
  370. #-}
  371. Then (because RULES are applied inside INLINABLE unfoldings, but inlinings
  372. are not), the unfolding given to "filter" in the interface file will be:
  373. filter p [] = []
  374. filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)
  375. else build (\c n -> foldr (filterFB c p) n xs
  376. Note that because this unfolding does not mention "filter", filter is not
  377. marked as a strong loop breaker. Therefore at a use site in another module:
  378. filter p xs
  379. = {inline}
  380. case xs of [] -> []
  381. (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)
  382. else build (\c n -> foldr (filterFB c p) n xs)
  383. build (\c n -> foldr (filterFB c p) n xs)
  384. = {inline} foldr (filterFB (:) p) [] xs
  385. = {RULE} filter p xs
  386. And we are in an infinite loop again, except that this time the loop is producing an
  387. infinitely large *term* (an unrolling of filter) and so the simplifier finally
  388. dies with "ticks exhausted"
  389. Because of this problem, we make a small change in the occurrence analyser
  390. designed to mark functions like "filter" as strong loop breakers on the basis that:
  391. 1. The RHS of filter mentions the local function "filterFB"
  392. 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS
  393. So for each RULE for an *imported* function we are going to add
  394. dependency edges between the *local* FVS of the rule LHS and the
  395. *local* FVS of the rule RHS. We don't do anything special for RULES on
  396. local functions because the standard occurrence analysis stuff is
  397. pretty good at getting loop-breakerness correct there.
  398. It is important to note that even with this extra hack we aren't always going to get
  399. things right. For example, it might be that the rule LHS mentions an imported Id,
  400. and another module has a RULE that can rewrite that imported Id to one of our local
  401. Ids.
  402. Note [Specialising imported functions]
  403. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  404. BUT for *automatically-generated* rules, the programmer can't be
  405. responsible for the "programmer error" in Note [Rules for imported
  406. functions]. In paricular, consider specialising a recursive function
  407. defined in another module. If we specialise a recursive function B.g,
  408. we get
  409. g_spec = .....(B.g Int).....
  410. RULE B.g Int = g_spec
  411. Here, g_spec doesn't look recursive, but when the rule fires, it
  412. becomes so. And if B.g was mutually recursive, the loop might
  413. not be as obvious as it is here.
  414. To avoid this,
  415. * When specialising a function that is a loop breaker,
  416. give a NOINLINE pragma to the specialised function
  417. Note [Glomming]
  418. ~~~~~~~~~~~~~~~
  419. RULES for imported Ids can make something at the top refer to something at the bottom:
  420. f = \x -> B.g (q x)
  421. h = \y -> 3
  422. RULE: B.g (q x) = h x
  423. Applying this rule makes f refer to h, although f doesn't appear to
  424. depend on h. (And, as in Note [Rules for imported functions], the
  425. dependency might be more indirect. For example, f might mention C.t
  426. rather than B.g, where C.t eventually inlines to B.g.)
  427. NOTICE that this cannot happen for rules whose head is a
  428. locally-defined function, because we accurately track dependencies
  429. through RULES. It only happens for rules whose head is an imported
  430. function (B.g in the example above).
  431. Solution:
  432. - When simplifying, bring all top level identifiers into
  433. scope at the start, ignoring the Rec/NonRec structure, so
  434. that when 'h' pops up in f's rhs, we find it in the in-scope set
  435. (as the simplifier generally expects). This happens in simplTopBinds.
  436. - In the occurrence analyser, if there are any out-of-scope
  437. occurrences that pop out of the top, which will happen after
  438. firing the rule: f = \x -> h x
  439. h = \y -> 3
  440. then just glom all the bindings into a single Rec, so that
  441. the *next* iteration of the occurrence analyser will sort
  442. them all out. This part happens in occurAnalysePgm.
  443. ------------------------------------------------------------
  444. Note [Inline rules]
  445. ~~~~~~~~~~~~~~~~~~~
  446. None of the above stuff about RULES applies to Inline Rules,
  447. stored in a CoreUnfolding. The unfolding, if any, is simplified
  448. at the same time as the regular RHS of the function (ie *not* like
  449. Note [Rules are visible in their own rec group]), so it should be
  450. treated *exactly* like an extra RHS.
  451. Or, rather, when computing loop-breaker edges,
  452. * If f has an INLINE pragma, and it is active, we treat the
  453. INLINE rhs as f's rhs
  454. * If it's inactive, we treat f as having no rhs
  455. * If it has no INLINE pragma, we look at f's actual rhs
  456. There is a danger that we'll be sub-optimal if we see this
  457. f = ...f...
  458. [INLINE f = ..no f...]
  459. where f is recursive, but the INLINE is not. This can just about
  460. happen with a sufficiently odd set of rules; eg
  461. foo :: Int -> Int
  462. {-# INLINE [1] foo #-}
  463. foo x = x+1
  464. bar :: Int -> Int
  465. {-# INLINE [1] bar #-}
  466. bar x = foo x + 1
  467. {-# RULES "foo" [~1] forall x. foo x = bar x #-}
  468. Here the RULE makes bar recursive; but it's INLINE pragma remains
  469. non-recursive. It's tempting to then say that 'bar' should not be
  470. a loop breaker, but an attempt to do so goes wrong in two ways:
  471. a) We may get
  472. $df = ...$cfoo...
  473. $cfoo = ...$df....
  474. [INLINE $cfoo = ...no-$df...]
  475. But we want $cfoo to depend on $df explicitly so that we
  476. put the bindings in the right order to inline $df in $cfoo
  477. and perhaps break the loop altogether. (Maybe this
  478. b)
  479. Example [eftInt]
  480. ~~~~~~~~~~~~~~~
  481. Example (from GHC.Enum):
  482. eftInt :: Int# -> Int# -> [Int]
  483. eftInt x y = ...(non-recursive)...
  484. {-# INLINE [0] eftIntFB #-}
  485. eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
  486. eftIntFB c n x y = ...(non-recursive)...
  487. {-# RULES
  488. "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
  489. "eftIntList" [1] eftIntFB (:) [] = eftInt
  490. #-}
  491. Note [Specialisation rules]
  492. ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  493. Consider this group, which is typical of what SpecConstr builds:
  494. fs a = ....f (C a)....
  495. f x = ....f (C a)....
  496. {-# RULE f (C a) = fs a #-}
  497. So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
  498. But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
  499. - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
  500. - fs is inlined (say it's small)
  501. - now there's another opportunity to apply the RULE
  502. This showed up when compiling Control.Concurrent.Chan.getChanContents.
  503. \begin{code}
  504. type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
  505. -- which is gotten from the Id.
  506. data Details
  507. = ND { nd_bndr :: Id -- Binder
  508. , nd_rhs :: CoreExpr -- RHS, already occ-analysed
  509. , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and InlineRule unfolding
  510. -- ignoring phase (ie assuming all are active)
  511. -- See Note [Forming Rec groups]
  512. , nd_inl :: IdSet -- Free variables of
  513. -- the InlineRule (if present and active)
  514. -- or the RHS (ir no InlineRule)
  515. -- but excluding any RULES
  516. -- This is the IdSet that may be used if the Id is inlined
  517. , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds
  518. -- but are *not* in nd_inl. These are the ones whose
  519. -- dependencies might not be respected by loop_breaker_edges
  520. -- See Note [Weak loop breakers]
  521. , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES
  522. }
  523. instance Outputable Details where
  524. ppr nd = ptext (sLit "ND") <> braces
  525. (sep [ ptext (sLit "bndr =") <+> ppr (nd_bndr nd)
  526. , ptext (sLit "uds =") <+> ppr (nd_uds nd)
  527. , ptext (sLit "inl =") <+> ppr (nd_inl nd)
  528. , ptext (sLit "weak =") <+> ppr (nd_weak nd)
  529. , ptext (sLit "rule =") <+> ppr (nd_active_rule_fvs nd)
  530. ])
  531. makeNode :: OccEnv -> IdEnv IdSet -> VarSet -> (Var, CoreExpr) -> Node Details
  532. makeNode env imp_rules_edges bndr_set (bndr, rhs)
  533. = (details, varUnique bndr, keysUFM node_fvs)
  534. where
  535. details = ND { nd_bndr = bndr
  536. , nd_rhs = rhs'
  537. , nd_uds = rhs_usage3
  538. , nd_weak = node_fvs `minusVarSet` inl_fvs
  539. , nd_inl = inl_fvs
  540. , nd_active_rule_fvs = active_rule_fvs }
  541. -- Constructing the edges for the main Rec computation
  542. -- See Note [Forming Rec groups]
  543. (rhs_usage1, rhs') = occAnalRecRhs env rhs
  544. rhs_usage2 = addIdOccs rhs_usage1 all_rule_fvs -- Note [Rules are extra RHSs]
  545. -- Note [Rule dependency info]
  546. rhs_usage3 = case mb_unf_fvs of
  547. Just unf_fvs -> addIdOccs rhs_usage2 unf_fvs
  548. Nothing -> rhs_usage2
  549. node_fvs = udFreeVars bndr_set rhs_usage3
  550. -- Finding the free variables of the rules
  551. is_active = occ_rule_act env :: Activation -> Bool
  552. rules = filterOut isBuiltinRule (idCoreRules bndr)
  553. rules_w_fvs :: [(Activation, VarSet)] -- Find the RHS fvs
  554. rules_w_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) (lookupVarEnv imp_rules_edges bndr)
  555. -- See Note [Preventing loops due to imported functions rules]
  556. [ (ru_act rule, fvs)
  557. | rule <- rules
  558. , let fvs = exprFreeVars (ru_rhs rule)
  559. `delVarSetList` ru_bndrs rule
  560. , not (isEmptyVarSet fvs) ]
  561. all_rule_fvs = foldr (unionVarSet . snd) rule_lhs_fvs rules_w_fvs
  562. rule_lhs_fvs = foldr (unionVarSet . (\ru -> exprsFreeVars (ru_args ru)
  563. `delVarSetList` ru_bndrs ru))
  564. emptyVarSet rules
  565. active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_fvs, is_active a]
  566. -- Finding the free variables of the INLINE pragma (if any)
  567. unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag
  568. mb_unf_fvs = stableUnfoldingVars unf
  569. -- Find the "nd_inl" free vars; for the loop-breaker phase
  570. inl_fvs = case mb_unf_fvs of
  571. Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS
  572. Just unf_fvs -> unf_fvs
  573. -- We could check for an *active* INLINE (returning
  574. -- emptyVarSet for an inactive one), but is_active
  575. -- isn't the right thing (it tells about
  576. -- RULE activation), so we'd need more plumbing
  577. -----------------------------
  578. occAnalRec :: SCC (Node Details)
  579. -> (UsageDetails, [CoreBind])
  580. -> (UsageDetails, [CoreBind])
  581. -- The NonRec case is just like a Let (NonRec ...) above
  582. occAnalRec (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_uds}, _, _))
  583. (body_uds, binds)
  584. | not (bndr `usedIn` body_uds)
  585. = (body_uds, binds) -- See Note [Dead code]
  586. | otherwise -- It's mentioned in the body
  587. = (body_uds' +++ rhs_uds,
  588. NonRec tagged_bndr rhs : binds)
  589. where
  590. (body_uds', tagged_bndr) = tagBinder body_uds bndr
  591. -- The Rec case is the interesting one
  592. -- See Note [Loop breaking]
  593. occAnalRec (CyclicSCC nodes) (body_uds, binds)
  594. | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds
  595. = (body_uds, binds) -- See Note [Dead code]
  596. | otherwise -- At this point we always build a single Rec
  597. = -- pprTrace "occAnalRec" (vcat
  598. -- [ text "tagged nodes" <+> ppr tagged_nodes
  599. -- , text "lb edges" <+> ppr loop_breaker_edges])
  600. (final_uds, Rec pairs : binds)
  601. where
  602. bndrs = [b | (ND { nd_bndr = b }, _, _) <- nodes]
  603. bndr_set = mkVarSet bndrs
  604. ----------------------------
  605. -- Tag the binders with their occurrence info
  606. tagged_nodes = map tag_node nodes
  607. total_uds = foldl add_uds body_uds nodes
  608. final_uds = total_uds `minusVarEnv` bndr_set
  609. add_uds usage_so_far (nd, _, _) = usage_so_far +++ nd_uds nd
  610. tag_node :: Node Details -> Node Details
  611. tag_node (details@ND { nd_bndr = bndr }, k, ks)
  612. = (details { nd_bndr = setBinderOcc total_uds bndr }, k, ks)
  613. ---------------------------
  614. -- Now reconstruct the cycle
  615. pairs :: [(Id,CoreExpr)]
  616. pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs tagged_nodes []
  617. | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_edges []
  618. -- If weak_fvs is empty, the loop_breaker_edges will include all
  619. -- the edges in tagged_nodes, so there isn't any point in doing
  620. -- a fresh SCC computation that will yield a single CyclicSCC result.
  621. weak_fvs :: VarSet
  622. weak_fvs = foldr (unionVarSet . nd_weak . fstOf3) emptyVarSet nodes
  623. -- See Note [Choosing loop breakers] for loop_breaker_edges
  624. loop_breaker_edges = map mk_node tagged_nodes
  625. mk_node (details@(ND { nd_inl = inl_fvs }), k, _)
  626. = (details, k, keysUFM (extendFvs_ rule_fv_env inl_fvs))
  627. ------------------------------------
  628. rule_fv_env :: IdEnv IdSet
  629. -- Maps a variable f to the variables from this group
  630. -- mentioned in RHS of active rules for f
  631. -- Domain is *subset* of bound vars (others have no rule fvs)
  632. rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs)
  633. init_rule_fvs -- See Note [Finding rule RHS free vars]
  634. = [ (b, trimmed_rule_fvs)
  635. | (ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs },_,_) <- nodes
  636. , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set
  637. , not (isEmptyVarSet trimmed_rule_fvs)]
  638. \end{code}
  639. @loopBreakSCC@ is applied to the list of (binder,rhs) pairs for a cyclic
  640. strongly connected component (there's guaranteed to be a cycle). It returns the
  641. same pairs, but
  642. a) in a better order,
  643. b) with some of the Ids having a IAmALoopBreaker pragma
  644. The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
  645. that the simplifier can guarantee not to loop provided it never records an inlining
  646. for these no-inline guys.
  647. Furthermore, the order of the binds is such that if we neglect dependencies
  648. on the no-inline Ids then the binds are topologically sorted. This means
  649. that the simplifier will generally do a good job if it works from top bottom,
  650. recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
  651. \begin{code}
  652. type Binding = (Id,CoreExpr)
  653. mk_loop_breaker :: Node Details -> Binding
  654. mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
  655. = (setIdOccInfo bndr strongLoopBreaker, rhs)
  656. mk_non_loop_breaker :: VarSet -> Node Details -> Binding
  657. -- See Note [Weak loop breakers]
  658. mk_non_loop_breaker used_in_rules (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
  659. | bndr `elemVarSet` used_in_rules = (setIdOccInfo bndr weakLoopBreaker, rhs)
  660. | otherwise = (bndr, rhs)
  661. udFreeVars :: VarSet -> UsageDetails -> VarSet
  662. -- Find the subset of bndrs that are mentioned in uds
  663. udFreeVars bndrs uds = intersectUFM_C (\b _ -> b) bndrs uds
  664. loopBreakNodes :: Int
  665. -> VarSet -- All binders
  666. -> VarSet -- Binders whose dependencies may be "missing"
  667. -- See Note [Weak loop breakers]
  668. -> [Node Details]
  669. -> [Binding] -- Append these to the end
  670. -> [Binding]
  671. -- Return the bindings sorted into a plausible order, and marked with loop breakers.
  672. loopBreakNodes depth bndr_set weak_fvs nodes binds
  673. = go (stronglyConnCompFromEdgedVerticesR nodes) binds
  674. where
  675. go [] binds = binds
  676. go (scc:sccs) binds = loop_break_scc scc (go sccs binds)
  677. loop_break_scc scc binds
  678. = case scc of
  679. AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds
  680. CyclicSCC [node] -> mk_loop_breaker node : binds
  681. CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds
  682. reOrderNodes :: Int -> VarSet -> VarSet -> [Node Details] -> [Binding] -> [Binding]
  683. -- Choose a loop breaker, mark it no-inline,
  684. -- do SCC analysis on the rest, and recursively sort them out
  685. reOrderNodes _ _ _ [] _ = panic "reOrderNodes"
  686. reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
  687. = -- pprTrace "reOrderNodes" (text "unchosen" <+> ppr unchosen $$
  688. -- text "chosen" <+> ppr chosen_nodes) $
  689. loopBreakNodes new_depth bndr_set weak_fvs unchosen $
  690. (map mk_loop_breaker chosen_nodes ++ binds)
  691. where
  692. (chosen_nodes, unchosen) = choose_loop_breaker (score node) [node] [] nodes
  693. approximate_loop_breaker = depth >= 2
  694. new_depth | approximate_loop_breaker = 0
  695. | otherwise = depth+1
  696. -- After two iterations (d=0, d=1) give up
  697. -- and approximate, returning to d=0
  698. choose_loop_breaker :: Int -- Best score so far
  699. -> [Node Details] -- Nodes with this score
  700. -> [Node Details] -- Nodes with higher scores
  701. -> [Node Details] -- Unprocessed nodes
  702. -> ([Node Details], [Node Details])
  703. -- This loop looks for the bind with the lowest score
  704. -- to pick as the loop breaker. The rest accumulate in
  705. choose_loop_breaker _ loop_nodes acc []
  706. = (loop_nodes, acc) -- Done
  707. -- If approximate_loop_breaker is True, we pick *all*
  708. -- nodes with lowest score, else just one
  709. -- See Note [Complexity of loop breaking]
  710. choose_loop_breaker loop_sc loop_nodes acc (node : nodes)
  711. | sc < loop_sc -- Lower score so pick this new one
  712. = choose_loop_breaker sc [node] (loop_nodes ++ acc) nodes
  713. | approximate_loop_breaker && sc == loop_sc
  714. = choose_loop_breaker loop_sc (node : loop_nodes) acc nodes
  715. | otherwise -- Higher score so don't pick it
  716. = choose_loop_breaker loop_sc loop_nodes (node : acc) nodes
  717. where
  718. sc = score node
  719. score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
  720. score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)
  721. | not (isId bndr) = 100 -- A type or cercion variable is never a loop breaker
  722. | isDFunId bndr = 9 -- Never choose a DFun as a loop breaker
  723. -- Note [DFuns should not be loop breakers]
  724. | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr)
  725. = case inl_source of
  726. InlineWrapper {} -> 10 -- Note [INLINE pragmas]
  727. _other -> 3 -- Data structures are more important than this
  728. -- so that dictionary/method recursion unravels
  729. -- Note that this case hits all InlineRule things, so we
  730. -- never look at 'rhs' for InlineRule stuff. That's right, because
  731. -- 'rhs' is irrelevant for inlining things with an InlineRule
  732. | is_con_app rhs = 5 -- Data types help with cases: Note [Constructor applications]
  733. | exprIsTrivial rhs = 10 -- Practically certain to be inlined
  734. -- Used to have also: && not (isExportedId bndr)
  735. -- But I found this sometimes cost an extra iteration when we have
  736. -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
  737. -- where df is the exported dictionary. Then df makes a really
  738. -- bad choice for loop breaker
  739. -- If an Id is marked "never inline" then it makes a great loop breaker
  740. -- The only reason for not checking that here is that it is rare
  741. -- and I've never seen a situation where it makes a difference,
  742. -- so it probably isn't worth the time to test on every binder
  743. -- | isNeverActive (idInlinePragma bndr) = -10
  744. | isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined
  745. | canUnfold (realIdUnfolding bndr) = 1
  746. -- The Id has some kind of unfolding
  747. -- Ignore loop-breaker-ness here because that is what we are setting!
  748. | otherwise = 0
  749. -- Checking for a constructor application
  750. -- Cheap and cheerful; the simplifer moves casts out of the way
  751. -- The lambda case is important to spot x = /\a. C (f a)
  752. -- which comes up when C is a dictionary constructor and
  753. -- f is a default method.
  754. -- Example: the instance for Show (ST s a) in GHC.ST
  755. --
  756. -- However we *also* treat (\x. C p q) as a con-app-like thing,
  757. -- Note [Closure conversion]
  758. is_con_app (Var v) = isConLikeId v
  759. is_con_app (App f _) = is_con_app f
  760. is_con_app (Lam _ e) = is_con_app e
  761. is_con_app (Tick _ e) = is_con_app e
  762. is_con_app _ = False
  763. \end{code}
  764. Note [Complexity of loop breaking]
  765. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  766. The loop-breaking algorithm knocks out one binder at a time, and
  767. performs a new SCC analysis on the remaining binders. That can
  768. behave very badly in tightly-coupled groups of bindings; in the
  769. worst case it can be (N**2)*log N, because it does a full SCC
  770. on N, then N-1, then N-2 and so on.
  771. To avoid this, we switch plans after 2 (or whatever) attempts:
  772. Plan A: pick one binder with the lowest score, make it
  773. a loop breaker, and try again
  774. Plan B: pick *all* binders with the lowest score, make them
  775. all loop breakers, and try again
  776. Since there are only a small finite number of scores, this will
  777. terminate in a constant number of iterations, rather than O(N)
  778. iterations.
  779. You might thing that it's very unlikely, but RULES make it much
  780. more likely. Here's a real example from Trac #1969:
  781. Rec { $dm = \d.\x. op d
  782. {-# RULES forall d. $dm Int d = $s$dm1
  783. forall d. $dm Bool d = $s$dm2 #-}
  784. dInt = MkD .... opInt ...
  785. dInt = MkD .... opBool ...
  786. opInt = $dm dInt
  787. opBool = $dm dBool
  788. $s$dm1 = \x. op dInt
  789. $s$dm2 = \x. op dBool }
  790. The RULES stuff means that we can't choose $dm as a loop breaker
  791. (Note [Choosing loop breakers]), so we must choose at least (say)
  792. opInt *and* opBool, and so on. The number of loop breakders is
  793. linear in the number of instance declarations.
  794. Note [INLINE pragmas]
  795. ~~~~~~~~~~~~~~~~~~~~~
  796. Avoid choosing a function with an INLINE pramga as the loop breaker!
  797. If such a function is mutually-recursive with a non-INLINE thing,
  798. then the latter should be the loop-breaker.
  799. Usually this is just a question of optimisation. But a particularly
  800. bad case is wrappers generated by the demand analyser: if you make
  801. then into a loop breaker you may get an infinite inlining loop. For
  802. example:
  803. rec {
  804. $wfoo x = ....foo x....
  805. {-loop brk-} foo x = ...$wfoo x...
  806. }
  807. The interface file sees the unfolding for $wfoo, and sees that foo is
  808. strict (and hence it gets an auto-generated wrapper). Result: an
  809. infinite inlining in the importing scope. So be a bit careful if you
  810. change this. A good example is Tree.repTree in
  811. nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
  812. breaker then compiling Game.hs goes into an infinite loop. This
  813. happened when we gave is_con_app a lower score than inline candidates:
  814. Tree.repTree
  815. = __inline_me (/\a. \w w1 w2 ->
  816. case Tree.$wrepTree @ a w w1 w2 of
  817. { (# ww1, ww2 #) -> Branch @ a ww1 ww2 })
  818. Tree.$wrepTree
  819. = /\a w w1 w2 ->
  820. (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #)
  821. Here we do *not* want to choose 'repTree' as the loop breaker.
  822. Note [DFuns should not be loop breakers]
  823. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  824. It's particularly bad to make a DFun into a loop breaker. See
  825. Note [How instance declarations are translated] in TcInstDcls
  826. We give DFuns a higher score than ordinary CONLIKE things because
  827. if there's a choice we want the DFun to be the non-looop breker. Eg
  828. rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)
  829. $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)
  830. {-# DFUN #-}
  831. $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)
  832. }
  833. Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it
  834. if we can't unravel the DFun first.
  835. Note [Constructor applications]
  836. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  837. It's really really important to inline dictionaries. Real
  838. example (the Enum Ordering instance from GHC.Base):
  839. rec f = \ x -> case d of (p,q,r) -> p x
  840. g = \ x -> case d of (p,q,r) -> q x
  841. d = (v, f, g)
  842. Here, f and g occur just once; but we can't inline them into d.
  843. On the other hand we *could* simplify those case expressions if
  844. we didn't stupidly choose d as the loop breaker.
  845. But we won't because constructor args are marked "Many".
  846. Inlining dictionaries is really essential to unravelling
  847. the loops in static numeric dictionaries, see GHC.Float.
  848. Note [Closure conversion]
  849. ~~~~~~~~~~~~~~~~~~~~~~~~~
  850. We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
  851. The immediate motivation came from the result of a closure-conversion transformation
  852. which generated code like this:
  853. data Clo a b = forall c. Clo (c -> a -> b) c
  854. ($:) :: Clo a b -> a -> b
  855. Clo f env $: x = f env x
  856. rec { plus = Clo plus1 ()
  857. ; plus1 _ n = Clo plus2 n
  858. ; plus2 Zero n = n
  859. ; plus2 (Succ m) n = Succ (plus $: m $: n) }
  860. If we inline 'plus' and 'plus1', everything unravels nicely. But if
  861. we choose 'plus1' as the loop breaker (which is entirely possible
  862. otherwise), the loop does not unravel nicely.
  863. @occAnalRhs@ deals with the question of bindings where the Id is marked
  864. by an INLINE pragma. For these we record that anything which occurs
  865. in its RHS occurs many times. This pessimistically assumes that ths
  866. inlined binder also occurs many times in its scope, but if it doesn't
  867. we'll catch it next time round. At worst this costs an extra simplifier pass.
  868. ToDo: try using the occurrence info for the inline'd binder.
  869. [March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC.
  870. [June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC.
  871. \begin{code}
  872. occAnalRecRhs :: OccEnv -> CoreExpr -- Rhs
  873. -> (UsageDetails, CoreExpr)
  874. -- Returned usage details covers only the RHS,
  875. -- and *not* the RULE or INLINE template for the Id
  876. occAnalRecRhs env rhs = occAnal (rhsCtxt env) rhs
  877. occAnalNonRecRhs :: OccEnv
  878. -> Id -> CoreExpr -- Binder and rhs
  879. -- Binder is already tagged with occurrence info
  880. -> (UsageDetails, CoreExpr)
  881. -- Returned usage details covers only the RHS,
  882. -- and *not* the RULE or INLINE template for the Id
  883. occAnalNonRecRhs env bndr rhs
  884. = occAnal rhs_env rhs
  885. where
  886. -- See Note [Use one-shot info]
  887. env1 = env { occ_one_shots = argOneShots dmd }
  888. -- See Note [Cascading inlines]
  889. rhs_env | certainly_inline = env1
  890. | otherwise = rhsCtxt env1
  891. certainly_inline -- See Note [Cascading inlines]
  892. = case idOccInfo bndr of
  893. OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable
  894. _ -> False
  895. dmd = idDemandInfo bndr
  896. active = isAlwaysActive (idInlineActivation bndr)
  897. not_stable = not (isStableUnfolding (idUnfolding bndr))
  898. addIdOccs :: UsageDetails -> VarSet -> UsageDetails
  899. addIdOccs usage id_set = foldVarSet add usage id_set
  900. where
  901. add v u | isId v = addOneOcc u v NoOccInfo
  902. | otherwise = u
  903. -- Give a non-committal binder info (i.e NoOccInfo) because
  904. -- a) Many copies of the specialised thing can appear
  905. -- b) We don't want to substitute a BIG expression inside a RULE
  906. -- even if that's the only occurrence of the thing
  907. -- (Same goes for INLINE.)
  908. \end{code}
  909. Note [Cascading inlines]
  910. ~~~~~~~~~~~~~~~~~~~~~~~~
  911. By default we use an rhsCtxt for the RHS of a binding. This tells the
  912. occ anal n that it's looking at an RHS, which has an effect in
  913. occAnalApp. In particular, for constructor applications, it makes
  914. the arguments appear to have NoOccInfo, so that we don't inline into
  915. them. Thus x = f y
  916. k = Just x
  917. we do not want to inline x.
  918. But there's a problem. Consider
  919. x1 = a0 : []
  920. x2 = a1 : x1
  921. x3 = a2 : x2
  922. g = f x3
  923. First time round, it looks as if x1 and x2 occur as an arg of a
  924. let-bound constructor ==> give them a many-occurrence.
  925. But then x3 is inlined (unconditionally as it happens) and
  926. next time round, x2 will be, and the next time round x1 will be
  927. Result: multiple simplifier iterations. Sigh.
  928. So, when analysing the RHS of x3 we notice that x3 will itself
  929. definitely inline the next time round, and so we analyse x3's rhs in
  930. an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff.
  931. Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally.
  932. If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates
  933. indefinitely:
  934. x = f y
  935. k = Just x
  936. inline ==>
  937. k = Just (f y)
  938. float ==>
  939. x1 = f y
  940. k = Just x1
  941. This is worse than the slow cascade, so we only want to say "certainly_inline"
  942. if it really is certain. Look at the note with preInlineUnconditionally
  943. for the various clauses.
  944. Expressions
  945. ~~~~~~~~~~~
  946. \begin{code}
  947. occAnal :: OccEnv
  948. -> CoreExpr
  949. -> (UsageDetails, -- Gives info only about the "interesting" Ids
  950. CoreExpr)
  951. occAnal _ expr@(Type _) = (emptyDetails, expr)
  952. occAnal _ expr@(Lit _) = (emptyDetails, expr)
  953. occAnal env expr@(Var v) = (mkOneOcc env v False, expr)
  954. -- At one stage, I gathered the idRuleVars for v here too,
  955. -- which in a way is the right thing to do.
  956. -- But that went wrong right after specialisation, when
  957. -- the *occurrences* of the overloaded function didn't have any
  958. -- rules in them, so the *specialised* versions looked as if they
  959. -- weren't used at all.
  960. occAnal _ (Coercion co)
  961. = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
  962. -- See Note [Gather occurrences of coercion veriables]
  963. \end{code}
  964. Note [Gather occurrences of coercion veriables]
  965. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  966. We need to gather info about what coercion variables appear, so that
  967. we can sort them into the right place when doing dependency analysis.
  968. \begin{code}
  969. occAnal env (Tick tickish body)
  970. | Breakpoint _ ids <- tickish
  971. = (mapVarEnv markInsideSCC usage
  972. +++ mkVarEnv (zip ids (repeat NoOccInfo)), Tick tickish body')
  973. -- never substitute for any of the Ids in a Breakpoint
  974. | tickishScoped tickish
  975. = (mapVarEnv markInsideSCC usage, Tick tickish body')
  976. | otherwise
  977. = (usage, Tick tickish body')
  978. where
  979. !(usage,body') = occAnal env body
  980. occAnal env (Cast expr co)
  981. = case occAnal env expr of { (usage, expr') ->
  982. let usage1 = markManyIf (isRhsEnv env) usage
  983. usage2 = addIdOccs usage1 (coVarsOfCo co)
  984. -- See Note [Gather occurrences of coercion veriables]
  985. in (usage2, Cast expr' co)
  986. -- If we see let x = y `cast` co
  987. -- then mark y as 'Many' so that we don't
  988. -- immediately inline y again.
  989. }
  990. \end{code}
  991. \begin{code}
  992. occAnal env app@(App _ _)
  993. = occAnalApp env (collectArgs app)
  994. -- Ignore type variables altogether
  995. -- (a) occurrences inside type lambdas only not marked as InsideLam
  996. -- (b) type variables not in environment
  997. occAnal env (Lam x body) | isTyVar x
  998. = case occAnal env body of { (body_usage, body') ->
  999. (body_usage, Lam x body')
  1000. }
  1001. -- For value lambdas we do a special hack. Consider
  1002. -- (\x. \y. ...x...)
  1003. -- If we did nothing, x is used inside the \y, so would be marked
  1004. -- as dangerous to dup. But in the common case where the abstraction
  1005. -- is applied to two arguments this is over-pessimistic.
  1006. -- So instead, we just mark each binder with its occurrence
  1007. -- info in the *body* of the multiple lambda.
  1008. -- Then, the simplifier is careful when partially applying lambdas.
  1009. occAnal env expr@(Lam _ _)
  1010. = case occAnal env_body body of { (body_usage, body') ->
  1011. let
  1012. (final_usage, tagged_binders) = tagLamBinders body_usage binders'
  1013. -- Use binders' to put one-shot info on the lambdas
  1014. really_final_usage | linear = final_usage
  1015. | otherwise = mapVarEnv markInsideLam final_usage
  1016. in
  1017. (really_final_usage, mkLams tagged_binders body') }
  1018. where
  1019. (binders, body) = collectBinders expr
  1020. (env_body, binders', linear) = oneShotGroup env binders
  1021. occAnal env (Case scrut bndr ty alts)
  1022. = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
  1023. case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') ->
  1024. let
  1025. alts_usage = foldr combineAltsUsageDetails emptyDetails alts_usage_s
  1026. (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
  1027. total_usage = scrut_usage +++ alts_usage1
  1028. in
  1029. total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
  1030. where
  1031. -- Note [Case binder usage]
  1032. -- ~~~~~~~~~~~~~~~~~~~~~~~~
  1033. -- The case binder gets a usage of either "many" or "dead", never "one".
  1034. -- Reason: we like to inline single occurrences, to eliminate a binding,
  1035. -- but inlining a case binder *doesn't* eliminate a binding.
  1036. -- We *don't* want to transform
  1037. -- case x of w { (p,q) -> f w }
  1038. -- into
  1039. -- case x of w { (p,q) -> f (p,q) }
  1040. tag_case_bndr usage bndr
  1041. = case lookupVarEnv usage bndr of
  1042. Nothing -> (usage, setIdOccInfo bndr IAmDead)
  1043. Just _ -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo)
  1044. alt_env = mkAltEnv env scrut bndr
  1045. occ_anal_alt = occAnalAlt alt_env bndr
  1046. occ_anal_scrut (Var v) (alt1 : other_alts)
  1047. | not (null other_alts) || not (isDefaultAlt alt1)
  1048. = (mkOneOcc env v True, Var v) -- The 'True' says that the variable occurs
  1049. -- in an interesting context; the case has
  1050. -- at least one non-default alternative
  1051. occ_anal_scrut scrut _alts
  1052. = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt
  1053. occAnal env (Let bind body)
  1054. = case occAnal env body of { (body_usage, body') ->
  1055. case occAnalBind env env emptyVarEnv bind body_usage of { (final_usage, new_binds) ->
  1056. (final_usage, mkLets new_binds body') }}
  1057. occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
  1058. occAnalArgs _ [] _
  1059. = (emptyDetails, [])
  1060. occAnalArgs env (arg:args) one_shots
  1061. | isTypeArg arg
  1062. = case occAnalArgs env args one_shots of { (uds, args') ->
  1063. (uds, arg:args') }
  1064. | otherwise
  1065. = case argCtxt env one_shots of { (arg_env, one_shots') ->
  1066. case occAnal arg_env arg of { (uds1, arg') ->
  1067. case occAnalArgs env args one_shots' of { (uds2, args') ->
  1068. (uds1 +++ uds2, arg':args') }}}
  1069. \end{code}
  1070. Applications are dealt with specially because we want
  1071. the "build hack" to work.
  1072. Note [Arguments of let-bound constructors]
  1073. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1074. Consider
  1075. f x = let y = expensive x in
  1076. let z = (True,y) in
  1077. (case z of {(p,q)->q}, case z of {(p,q)->q})
  1078. We feel free to duplicate the WHNF (True,y), but that means
  1079. that y may be duplicated thereby.
  1080. If we aren't careful we duplicate the (expensive x) call!
  1081. Constructors are rather like lambdas in this way.
  1082. \begin{code}
  1083. occAnalApp :: OccEnv
  1084. -> (Expr CoreBndr, [Arg CoreBndr])
  1085. -> (UsageDetails, Expr CoreBndr)
  1086. occAnalApp env (Var fun, args)
  1087. = case args_stuff of { (args_uds, args') ->
  1088. let
  1089. final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
  1090. -- We mark the free vars of the argument of a constructor or PAP
  1091. -- as "many", if it is the RHS of a let(rec).
  1092. -- This means that nothing gets inlined into a constructor argument
  1093. -- position, which is what we want. Typically those constructor
  1094. -- arguments are just variables, or trivial expressions.
  1095. --
  1096. -- This is the *whole point* of the isRhsEnv predicate
  1097. -- See Note [Arguments of let-bound constructors]
  1098. in
  1099. (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
  1100. where
  1101. fun_uds = mkOneOcc env fun (valArgCount args > 0)
  1102. is_exp = isExpandableApp fun (valArgCount args)
  1103. -- See Note [CONLIKE pragma] in BasicTypes
  1104. -- The definition of is_exp should match that in
  1105. -- Simplify.prepareRhs
  1106. one_shots = argsOneShots (idStrictness fun) (valArgCount args)
  1107. -- See Note [Use one-shot info]
  1108. args_stuff = occAnalArgs env args one_shots
  1109. -- (foldr k z xs) may call k many times, but it never
  1110. -- shares a partial application of k; hence [False,True]
  1111. -- This means we can optimise
  1112. -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
  1113. -- by floating in the v
  1114. occAnalApp env (fun, args)
  1115. = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
  1116. -- The addAppCtxt is a bit cunning. One iteration of the simplifier
  1117. -- often leaves behind beta redexs like
  1118. -- (\x y -> e) a1 a2
  1119. -- Here we would like to mark x,y as one-shot, and treat the whole
  1120. -- thing much like a let. We do this by pushing some True items
  1121. -- onto the context stack.
  1122. case occAnalArgs env args [] of { (args_uds, args') ->
  1123. (fun_uds +++ args_uds, mkApps fun' args') }}
  1124. markManyIf :: Bool -- If this is true
  1125. -> UsageDetails -- Then do markMany on this
  1126. -> UsageDetails
  1127. markManyIf True uds = mapVarEnv markMany uds
  1128. markManyIf False uds = uds
  1129. \end{code}
  1130. Note [Use one-shot information]
  1131. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1132. The occurrrence analyser propagates one-shot-lambda information in two situation
  1133. * Applications: eg build (\cn -> blah)
  1134. Propagate one-shot info from the strictness signature of 'build' to
  1135. the \cn
  1136. * Let-bindings: eg let f = \c. let ... in \n -> blah
  1137. in (build f, build f)
  1138. Propagate one-shot info from the demanand-info on 'f' to the
  1139. lambdas in its RHS (which may not be syntactically at the top)
  1140. Some of this is done by the demand analyser, but this way it happens
  1141. much earlier, taking advantage of the strictness signature of
  1142. imported functions.
  1143. Note [Binders in case alternatives]
  1144. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1145. Consider
  1146. case x of y { (a,b) -> f y }
  1147. We treat 'a', 'b' as dead, because they don't physically occur in the
  1148. case alternative. (Indeed, a variable is dead iff it doesn't occur in
  1149. its scope in the output of OccAnal.) It really helps to know when
  1150. binders are unused. See esp the call to isDeadBinder in
  1151. Simplify.mkDupableAlt
  1152. In this example, though, the Simplifier will bring 'a' and 'b' back to
  1153. life, beause it binds 'y' to (a,b) (imagine got inlined and
  1154. scrutinised y).
  1155. \begin{code}
  1156. occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))
  1157. -> CoreBndr
  1158. -> CoreAlt
  1159. -> (UsageDetails, Alt IdWithOccInfo)
  1160. occAnalAlt (env, scrut_bind) case_bndr (con, bndrs, rhs)
  1161. = case occAnal env rhs of { (rhs_usage1, rhs1) ->
  1162. let
  1163. (rhs_usage2, rhs2) =
  1164. wrapProxy (occ_binder_swap env) scrut_bind case_bndr rhs_usage1 rhs1
  1165. (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs
  1166. bndrs' = tagged_bndrs -- See Note [Binders in case alternatives]
  1167. in
  1168. (alt_usg, (con, bndrs', rhs2)) }
  1169. wrapProxy :: Bool -> Maybe (Id, CoreExpr) -> Id -> UsageDetails -> CoreExpr -> (UsageDetails, CoreExpr)
  1170. wrapProxy enable_binder_swap (Just (scrut_var, rhs)) case_bndr body_usg body
  1171. | enable_binder_swap,
  1172. scrut_var `usedIn` body_usg
  1173. = ( body_usg' +++ unitVarEnv case_bndr NoOccInfo
  1174. , Let (NonRec tagged_scrut_var rhs) body )
  1175. where
  1176. (body_usg', tagged_scrut_var) = tagBinder body_usg scrut_var
  1177. wrapProxy _ _ _ body_usg body
  1178. = (body_usg, body)
  1179. \end{code}
  1180. %************************************************************************
  1181. %* *
  1182. OccEnv
  1183. %* *
  1184. %************************************************************************
  1185. \begin{code}
  1186. data OccEnv
  1187. = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
  1188. , occ_one_shots :: !OneShots -- Tells about linearity
  1189. , occ_gbl_scrut :: GlobalScruts
  1190. , occ_rule_act :: Activation -> Bool -- Which rules are active
  1191. -- See Note [Finding rule RHS free vars]
  1192. , occ_binder_swap :: !Bool -- enable the binder_swap
  1193. -- See CorePrep Note [Dead code in CorePrep]
  1194. }
  1195. type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees]
  1196. -----------------------------
  1197. -- OccEncl is used to control whether to inline into constructor arguments
  1198. -- For example:
  1199. -- x = (p,q) -- Don't inline p or q
  1200. -- y = /\a -> (p a, q a) -- Still don't inline p or q
  1201. -- z = f (p,q) -- Do inline p,q; it may make a rule fire
  1202. -- So OccEncl tells enought about the context to know what to do when
  1203. -- we encounter a contructor application or PAP.
  1204. data OccEncl
  1205. = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
  1206. -- Don't inline into constructor args here
  1207. | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
  1208. -- Do inline into constructor args here
  1209. instance Outputable OccEncl where
  1210. ppr OccRhs = ptext (sLit "occRhs")
  1211. ppr OccVanilla = ptext (sLit "occVanilla")
  1212. type OneShots = [Bool]
  1213. -- [] No info
  1214. --
  1215. -- True:ctxt Analysing a function-valued expression that will be
  1216. -- applied just once
  1217. --
  1218. -- False:ctxt Analysing a function-valued expression that may
  1219. -- be applied many times; but when it is,
  1220. -- the OneShots inside applies
  1221. initOccEnv :: (Activation -> Bool) -> OccEnv
  1222. initOccEnv active_rule
  1223. = OccEnv { occ_encl = OccVanilla
  1224. , occ_one_shots = []
  1225. , occ_gbl_scrut = emptyVarSet -- PE emptyVarEnv emptyVarSet
  1226. , occ_rule_act = active_rule
  1227. , occ_binder_swap = True }
  1228. vanillaCtxt :: OccEnv -> OccEnv
  1229. vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] }
  1230. rhsCtxt :: OccEnv -> OccEnv
  1231. rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }
  1232. argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
  1233. argCtxt env []
  1234. = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])
  1235. argCtxt env (one_shots:one_shots_s)
  1236. = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)
  1237. isRhsEnv :: OccEnv -> Bool
  1238. isRhsEnv (OccEnv { occ_encl = OccRhs }) = True
  1239. isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
  1240. oneShotGroup :: OccEnv -> [CoreBndr]
  1241. -> ( OccEnv
  1242. , [CoreBndr]
  1243. , Bool ) -- True <=> all binders are one-shot
  1244. -- The result binders have one-shot-ness set that they might not have had originally.
  1245. -- This happens in (build (\cn -> e)). Here the occurrence analyser
  1246. -- linearity context knows that c,n are one-shot, and it records that fact in
  1247. -- the binder. This is useful to guide subsequent float-in/float-out tranformations
  1248. oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs
  1249. = go ctxt bndrs [] True
  1250. where
  1251. go ctxt [] rev_bndrs linear
  1252. = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla }
  1253. , reverse rev_bndrs
  1254. , linear )
  1255. go ctxt (bndr:bndrs) rev_bndrs lin_acc
  1256. | isId bndr
  1257. = case ctxt of
  1258. [] -> go [] bndrs (bndr:rev_bndrs) (lin_acc && one_shot)
  1259. (linear : ctxt)
  1260. | one_shot -> go ctxt bndrs (bndr : rev_bndrs) lin_acc
  1261. | linear -> go ctxt bndrs (bndr': rev_bndrs) lin_acc
  1262. | otherwise -> go ctxt bndrs (bndr : rev_bndrs) False
  1263. | otherwise
  1264. = go ctxt bndrs (bndr:rev_bndrs) lin_acc
  1265. where
  1266. one_shot = isOneShotBndr bndr
  1267. bndr' = setOneShotLambda bndr
  1268. addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
  1269. addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args
  1270. = env { occ_one_shots = replicate (valArgCount args) True ++ ctxt }
  1271. \end{code}
  1272. \begin{code}
  1273. transClosureFV :: UniqFM VarSet -> UniqFM VarSet
  1274. -- If (f,g), (g,h) are in the input, then (f,h) is in the output
  1275. -- as well as (f,g), (g,h)
  1276. transClosureFV env
  1277. | no_change = env
  1278. | otherwise = transClosureFV (listToUFM new_fv_list)
  1279. where
  1280. (no_change, new_fv_list) = mapAccumL bump True (ufmToList env)
  1281. bump no_change (b,fvs)
  1282. | no_change_here = (no_change, (b,fvs))
  1283. | otherwise = (False, (b,new_fvs))
  1284. where
  1285. (new_fvs, no_change_here) = extendFvs env fvs
  1286. -------------
  1287. extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet
  1288. extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag
  1289. extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)
  1290. -- (extendFVs env s) returns
  1291. -- (s `union` env(s), env(s) `subset` s)
  1292. extendFvs env s
  1293. | isNullUFM env
  1294. = (s, True)
  1295. | otherwise
  1296. = (s `unionVarSet` extras, extras `subVarSet` s)
  1297. where
  1298. extras :: VarSet -- env(s)
  1299. extras = foldUFM unionVarSet emptyVarSet $
  1300. intersectUFM_C (\x _ -> x) env s
  1301. \end{code}
  1302. %************************************************************************
  1303. %* *
  1304. Binder swap
  1305. %* *
  1306. %************************************************************************
  1307. Note [Binder swap]
  1308. ~~~~~~~~~~~~~~~~~~
  1309. We do these two transformations right here:
  1310. (1) case x of b { pi -> ri }
  1311. ==>
  1312. case x of b { pi -> let x=b in ri }
  1313. (2) case (x |> co) of b { pi -> ri }
  1314. ==>
  1315. case (x |> co) of b { pi -> let x = b |> sym co in ri }
  1316. Why (2)? See Note [Case of cast]
  1317. In both cases, in a particular alternative (pi -> ri), we only
  1318. add the binding if
  1319. (a) x occurs free in (pi -> ri)
  1320. (ie it occurs in ri, but is not bound in pi)
  1321. (b) the pi does not bind b (or the free vars of co)
  1322. We need (a) and (b) for the inserted binding to be correct.
  1323. For the alternatives where we inject the binding, we can transfer
  1324. all x's OccInfo to b. And that is the point.
  1325. Notice that
  1326. * The deliberate shadowing of 'x'.
  1327. * That (a) rapidly becomes false, so no bindings are injected.
  1328. The reason for doing these transformations here is because it allows
  1329. us to adjust the OccInfo for 'x' and 'b' as we go.
  1330. * Suppose the only occurrences of 'x' are the scrutinee and in the
  1331. ri; then this transformation makes it occur just once, and hence
  1332. get inlined right away.
  1333. * If we do this in the Simplifier, we don't know whether 'x' is used
  1334. in ri, so we are forced to pessimistically zap b's OccInfo even
  1335. though it is typically dead (ie neither it nor x appear in the
  1336. ri). There's nothing actually wrong with zapping it, except that
  1337. it's kind of nice to know which variables are dead. My nose
  1338. tells me to keep this information as robustly as possible.
  1339. The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
  1340. {x=b}; it's Nothing if the binder-swap doesn't happen.
  1341. There is a danger though. Consider
  1342. let v = x +# y
  1343. in case (f v) of w -> ...v...v...
  1344. And suppose that (f v) expands to just v. Then we'd like to
  1345. use 'w' instead of 'v' in the alternative. But it may be too
  1346. late; we may have substituted the (cheap) x+#y for v in the
  1347. same simplifier pass that reduced (f v) to v.
  1348. I think this is just too bad. CSE will recover some of it.
  1349. Note [Case of cast]
  1350. ~~~~~~~~~~~~~~~~~~~
  1351. Consider case (x `cast` co) of b { I# ->
  1352. ... (case (x `cast` co) of {...}) ...
  1353. We'd like to eliminate the inner case. That is the motivation for
  1354. equation (2) in Note [Binder swap]. When we get to the inner case, we
  1355. inline x, cancel the casts, and away we go.
  1356. Note [Binder swap on GlobalId scrutinees]
  1357. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1358. When the scrutinee is a GlobalId we must take care in two ways
  1359. i) In order to *know* whether 'x' occurs free in the RHS, we need its
  1360. occurrence info. BUT, we don't gather occurrence info for
  1361. GlobalIds. That's the reason for the (small) occ_gbl_scrut env in
  1362. OccEnv is for: it says "gather occurrence info for these.
  1363. ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
  1364. has an External Name. See, for example, SimplEnv Note [Global Ids in
  1365. the substitution].
  1366. Note [Zap case binders in proxy bindings]
  1367. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1368. From the original
  1369. case x of cb(dead) { p -> ...x... }
  1370. we will get
  1371. case x of cb(live) { p -> let x = cb in ...x... }
  1372. Core Lint never expects to find an *occurence* of an Id marked
  1373. as Dead, so we must zap the OccInfo on cb before making the
  1374. binding x = cb. See Trac #5028.
  1375. Historical note [no-case-of-case]
  1376. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1377. We *used* to suppress the binder-swap in case expressions when
  1378. -fno-case-of-case is on. Old remarks:
  1379. "This happens in the first simplifier pass,
  1380. and enhances full laziness. Here's the bad case:
  1381. f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
  1382. If we eliminate the inner case, we trap it inside the I# v -> arm,
  1383. which might prevent some full laziness happening. I've seen this
  1384. in action in spectral/cichelli/Prog.hs:
  1385. [(m,n) | m <- [1..max], n <- [1..max]]
  1386. Hence the check for NoCaseOfCase."
  1387. However, now the full-laziness pass itself reverses the binder-swap, so this
  1388. check is no longer necessary.
  1389. Historical note [Suppressing the case binder-swap]
  1390. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1391. This old note describes a problem that is also fixed by doing the
  1392. binder-swap in OccAnal:
  1393. There is another situation when it might make sense to suppress the
  1394. case-expression binde-swap. If we have
  1395. case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
  1396. ...other cases .... }
  1397. We'll perform the binder-swap for the outer case, giving
  1398. case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
  1399. ...other cases .... }
  1400. But there is no point in doing it for the inner case, because w1 can't
  1401. be inlined anyway. Furthermore, doing the case-swapping involves
  1402. zapping w2's occurrence info (see paragraphs that follow), and that
  1403. forces us to bind w2 when doing case merging. So we get
  1404. case x of w1 { A -> let w2 = w1 in e1
  1405. B -> let w2 = w1 in e2
  1406. ...other cases .... }
  1407. This is plain silly in the common case where w2 is dead.
  1408. Even so, I can't see a good way to implement this idea. I tried
  1409. not doing the binder-swap if the scrutinee was already evaluated
  1410. but that failed big-time:
  1411. data T = MkT !Int
  1412. case v of w { MkT x ->
  1413. case x of x1 { I# y1 ->
  1414. case x of x2 { I# y2 -> ...
  1415. Notice that because MkT is strict, x is marked "evaluated". But to
  1416. eliminate the last case, we must either make sure that x (as well as
  1417. x1) has unfolding MkT y1. THe straightforward thing to do is to do
  1418. the binder-swap. So this whole note is a no-op.
  1419. It's fixed by doing the binder-swap in OccAnal because we can do the
  1420. binder-swap unconditionally and still get occurrence analysis
  1421. information right.
  1422. \begin{code}
  1423. mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
  1424. -- Does two things: a) makes the occ_one_shots = OccVanilla
  1425. -- b) extends the GlobalScruts if possible
  1426. -- c) returns a proxy mapping, binding the scrutinee
  1427. -- to the case binder, if possible
  1428. mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
  1429. = case scrut of
  1430. Var v -> add_scrut v case_bndr'
  1431. Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co))
  1432. -- See Note [Case of cast]
  1433. _ -> (env { occ_encl = OccVanilla }, Nothing)
  1434. where
  1435. add_scrut v rhs = ( env { occ_encl = OccVanilla, occ_gbl_scrut = pe `extendVarSet` v }
  1436. , Just (localise v, rhs) )
  1437. case_bndr' = Var (zapIdOccInfo case_bndr) -- See Note [Zap case binders in proxy bindings]
  1438. localise scrut_var = mkLocalId (localiseName (idName scrut_var)) (idType scrut_var)
  1439. -- Localise the scrut_var before shadowing it; we're making a
  1440. -- new binding for it, and it might have an External Name, or
  1441. -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
  1442. -- Also we don't want any INLINE or NOINLINE pragmas!
  1443. \end{code}
  1444. %************************************************************************
  1445. %* *
  1446. \subsection[OccurAnal-types]{OccEnv}
  1447. %* *
  1448. %************************************************************************
  1449. \begin{code}
  1450. type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
  1451. -- INVARIANT: never IAmDead
  1452. -- (Deadness is signalled by not being in the map at all)
  1453. (+++), combineAltsUsageDetails
  1454. :: UsageDetails -> UsageDetails -> UsageDetails
  1455. (+++) usage1 usage2
  1456. = plusVarEnv_C addOccInfo usage1 usage2
  1457. combineAltsUsageDetails usage1 usage2
  1458. = plusVarEnv_C orOccInfo usage1 usage2
  1459. addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
  1460. addOneOcc usage id info
  1461. = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
  1462. -- ToDo: make this more efficient
  1463. emptyDetails :: UsageDetails
  1464. emptyDetails = (emptyVarEnv :: UsageDetails)
  1465. usedIn :: Id -> UsageDetails -> Bool
  1466. v `usedIn` details = isExportedId v || v `elemVarEnv` details
  1467. type IdWithOccInfo = Id
  1468. tagLamBinders :: UsageDetails -- Of scope
  1469. -> [Id] -- Binders
  1470. -> (UsageDetails, -- Details with binders removed
  1471. [IdWithOccInfo]) -- Tagged binders
  1472. -- Used for lambda and case binders
  1473. -- It copes with the fact that lambda bindings can have InlineRule
  1474. -- unfoldings, used for join points
  1475. tagLamBinders usage binders = usage' `seq` (usage', bndrs')
  1476. where
  1477. (usage', bndrs') = mapAccumR tag_lam usage binders
  1478. tag_lam usage bndr = (usage2, setBinderOcc usage bndr)
  1479. where
  1480. usage1 = usage `delVarEnv` bndr
  1481. usage2 | isId bndr = addIdOccs usage1 (idUnfoldingVars bndr)
  1482. | otherwise = usage1
  1483. tagBinder :: UsageDetails -- Of scope
  1484. -> Id -- Binders
  1485. -> (UsageDetails, -- Details with binders removed
  1486. IdWithOccInfo) -- Tagged binders
  1487. tagBinder usage binder
  1488. = let
  1489. usage' = usage `delVarEnv` binder
  1490. binder' = setBinderOcc usage binder
  1491. in
  1492. usage' `seq` (usage', binder')
  1493. setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
  1494. setBinderOcc usage bndr
  1495. | isTyVar bndr = bndr
  1496. | isExportedId bndr = case idOccInfo bndr of
  1497. NoOccInfo -> bndr
  1498. _ -> setIdOccInfo bndr NoOccInfo
  1499. -- Don't use local usage info for visible-elsewhere things
  1500. -- BUT *do* erase any IAmALoopBreaker annotation, because we're
  1501. -- about to re-generate it and it shouldn't be "sticky"
  1502. | otherwise = setIdOccInfo bndr occ_info
  1503. where
  1504. occ_info = lookupVarEnv usage bndr `orElse` IAmDead
  1505. \end{code}
  1506. %************************************************************************
  1507. %* *
  1508. \subsection{Operations over OccInfo}
  1509. %* *
  1510. %************************************************************************
  1511. \begin{code}
  1512. mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
  1513. mkOneOcc env id int_cxt
  1514. | isLocalId id
  1515. = unitVarEnv id (OneOcc False True int_cxt)
  1516. | id `elemVarEnv` occ_gbl_scrut env
  1517. = unitVarEnv id NoOccInfo
  1518. | otherwise
  1519. = emptyDetails
  1520. markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
  1521. markMany _ = NoOccInfo
  1522. markInsideSCC occ = markInsideLam occ
  1523. -- inside an SCC, we can inline lambdas only.
  1524. markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
  1525. markInsideLam occ = occ
  1526. addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
  1527. addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
  1528. NoOccInfo -- Both branches are at least One
  1529. -- (Argument is never IAmDead)
  1530. -- (orOccInfo orig new) is used
  1531. -- when combining occurrence info from branches of a case
  1532. orOccInfo (OneOcc in_lam1 _ int_cxt1)
  1533. (OneOcc in_lam2 _ int_cxt2)
  1534. = OneOcc (in_lam1 || in_lam2)
  1535. False -- False, because it occurs in both branches
  1536. (int_cxt1 && int_cxt2)
  1537. orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
  1538. NoOccInfo
  1539. \end{code}