PageRenderTime 46ms CodeModel.GetById 16ms RepoModel.GetById 0ms app.codeStats 1ms

/compiler/simplCore/CSE.lhs

https://bitbucket.org/carter/ghc
Haskell | 396 lines | 278 code | 72 blank | 46 comment | 8 complexity | bd318b3795f9af73b7af3f44c3e7a54b MD5 | raw file
  1. %
  2. % (c) The AQUA Project, Glasgow University, 1993-1998
  3. %
  4. \section{Common subexpression}
  5. \begin{code}
  6. {-# OPTIONS -fno-warn-tabs #-}
  7. -- The above warning supression flag is a temporary kludge.
  8. -- While working on this module you are encouraged to remove it and
  9. -- detab the module (please do the detabbing in a separate patch). See
  10. -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
  11. -- for details
  12. module CSE (
  13. cseProgram
  14. ) where
  15. #include "HsVersions.h"
  16. -- Note [Keep old CSEnv rep]
  17. -- ~~~~~~~~~~~~~~~~~~~~~~~~~
  18. -- Temporarily retain code for the old representation for CSEnv
  19. -- Keeping it only so that we can switch back if a bug shows up
  20. -- or we want to do some performance comparisions
  21. --
  22. -- NB: when you remove this, also delete hashExpr from CoreUtils
  23. #ifdef OLD_CSENV_REP
  24. import CoreUtils ( exprIsBig, hashExpr, eqExpr )
  25. import StaticFlags ( opt_PprStyle_Debug )
  26. import Util ( lengthExceeds )
  27. import UniqFM
  28. import FastString
  29. #else
  30. import TrieMap
  31. #endif
  32. import CoreSubst
  33. import Var ( Var )
  34. import Id ( Id, idType, idInlineActivation, zapIdOccInfo )
  35. import CoreUtils ( mkAltExpr
  36. , exprIsTrivial)
  37. import Type ( tyConAppArgs )
  38. import CoreSyn
  39. import Outputable
  40. import BasicTypes ( isAlwaysActive )
  41. import Data.List
  42. \end{code}
  43. Simple common sub-expression
  44. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  45. When we see
  46. x1 = C a b
  47. x2 = C x1 b
  48. we build up a reverse mapping: C a b -> x1
  49. C x1 b -> x2
  50. and apply that to the rest of the program.
  51. When we then see
  52. y1 = C a b
  53. y2 = C y1 b
  54. we replace the C a b with x1. But then we *dont* want to
  55. add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1
  56. so that a subsequent binding
  57. y2 = C y1 b
  58. will get transformed to C x1 b, and then to x2.
  59. So we carry an extra var->var substitution which we apply *before* looking up in the
  60. reverse mapping.
  61. Note [Shadowing]
  62. ~~~~~~~~~~~~~~~~
  63. We have to be careful about shadowing.
  64. For example, consider
  65. f = \x -> let y = x+x in
  66. h = \x -> x+x
  67. in ...
  68. Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
  69. shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
  70. We can simply add clones to the substitution already described.
  71. Note [Case binders 1]
  72. ~~~~~~~~~~~~~~~~~~~~~~
  73. Consider
  74. f = \x -> case x of wild {
  75. (a:as) -> case a of wild1 {
  76. (p,q) -> ...(wild1:as)...
  77. Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
  78. But that's not quite obvious. In general we want to keep it as (wild1:as),
  79. but for CSE purpose that's a bad idea.
  80. So we add the binding (wild1 -> a) to the extra var->var mapping.
  81. Notice this is exactly backwards to what the simplifier does, which is
  82. to try to replaces uses of 'a' with uses of 'wild1'
  83. Note [Case binders 2]
  84. ~~~~~~~~~~~~~~~~~~~~~~
  85. Consider
  86. case (h x) of y -> ...(h x)...
  87. We'd like to replace (h x) in the alternative, by y. But because of
  88. the preceding [Note: case binders 1], we only want to add the mapping
  89. scrutinee -> case binder
  90. to the reverse CSE mapping if the scrutinee is a non-trivial expression.
  91. (If the scrutinee is a simple variable we want to add the mapping
  92. case binder -> scrutinee
  93. to the substitution
  94. Note [CSE for INLINE and NOINLINE]
  95. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  96. We are careful to do no CSE inside functions that the user has marked as
  97. INLINE or NOINLINE. In terms of Core, that means
  98. a) we do not do CSE inside an InlineRule
  99. b) we do not do CSE on the RHS of a binding b=e
  100. unless b's InlinePragma is AlwaysActive
  101. Here's why (examples from Roman Leshchinskiy). Consider
  102. yes :: Int
  103. {-# NOINLINE yes #-}
  104. yes = undefined
  105. no :: Int
  106. {-# NOINLINE no #-}
  107. no = undefined
  108. foo :: Int -> Int -> Int
  109. {-# NOINLINE foo #-}
  110. foo m n = n
  111. {-# RULES "foo/no" foo no = id #-}
  112. bar :: Int -> Int
  113. bar = foo yes
  114. We do not expect the rule to fire. But if we do CSE, then we get
  115. yes=no, and the rule does fire. Worse, whether we get yes=no or
  116. no=yes depends on the order of the definitions.
  117. In general, CSE should probably never touch things with INLINE pragmas
  118. as this could lead to surprising results. Consider
  119. {-# INLINE foo #-}
  120. foo = <rhs>
  121. {-# NOINLINE bar #-}
  122. bar = <rhs> -- Same rhs as foo
  123. If CSE produces
  124. foo = bar
  125. then foo will never be inlined (when it should be); but if it produces
  126. bar = foo
  127. bar will be inlined (when it should not be). Even if we remove INLINE foo,
  128. we'd still like foo to be inlined if rhs is small. This won't happen
  129. with foo = bar.
  130. Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
  131. a worker/wrapper, in which the worker has turned into a single variable:
  132. $wf = h
  133. f = \x -> ...$wf...
  134. Now CSE may transform to
  135. f = \x -> ...h...
  136. But the WorkerInfo for f still says $wf, which is now dead! This won't
  137. happen now that we don't look inside INLINEs (which wrappers are).
  138. %************************************************************************
  139. %* *
  140. \section{Common subexpression}
  141. %* *
  142. %************************************************************************
  143. \begin{code}
  144. cseProgram :: CoreProgram -> CoreProgram
  145. cseProgram binds = cseBinds emptyCSEnv binds
  146. cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
  147. cseBinds _ [] = []
  148. cseBinds env (b:bs) = (b':bs')
  149. where
  150. (env1, b') = cseBind env b
  151. bs' = cseBinds env1 bs
  152. cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
  153. cseBind env (NonRec b e)
  154. = (env2, NonRec b' e')
  155. where
  156. (env1, b') = addBinder env b
  157. (env2, e') = cseRhs env1 (b',e)
  158. cseBind env (Rec pairs)
  159. = (env2, Rec (bs' `zip` es'))
  160. where
  161. (bs,es) = unzip pairs
  162. (env1, bs') = addRecBinders env bs
  163. (env2, es') = mapAccumL cseRhs env1 (bs' `zip` es)
  164. cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr)
  165. cseRhs env (id',rhs)
  166. = case lookupCSEnv env rhs' of
  167. Just other_expr -> (env, other_expr)
  168. Nothing -> (addCSEnvItem env rhs' (Var id'), rhs')
  169. where
  170. rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs
  171. | otherwise = rhs
  172. -- See Note [CSE for INLINE and NOINLINE]
  173. tryForCSE :: CSEnv -> InExpr -> OutExpr
  174. tryForCSE env expr
  175. | exprIsTrivial expr' = expr' -- No point
  176. | Just smaller <- lookupCSEnv env expr' = smaller
  177. | otherwise = expr'
  178. where
  179. expr' = cseExpr env expr
  180. cseExpr :: CSEnv -> InExpr -> OutExpr
  181. cseExpr env (Type t) = Type (substTy (csEnvSubst env) t)
  182. cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c)
  183. cseExpr _ (Lit lit) = Lit lit
  184. cseExpr env (Var v) = lookupSubst env v
  185. cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
  186. cseExpr env (Tick t e) = Tick t (cseExpr env e)
  187. cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
  188. cseExpr env (Lam b e) = let (env', b') = addBinder env b
  189. in Lam b' (cseExpr env' e)
  190. cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
  191. in Let bind' (cseExpr env' e)
  192. cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts'
  193. where
  194. alts' = cseAlts env' scrut' bndr bndr'' alts
  195. scrut' = tryForCSE env scrut
  196. (env', bndr') = addBinder env bndr
  197. bndr'' = zapIdOccInfo bndr'
  198. -- The swizzling from Note [Case binders 2] may
  199. -- cause a dead case binder to be alive, so we
  200. -- play safe here and bring them all to life
  201. cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
  202. cseAlts env scrut' bndr bndr' alts
  203. = map cse_alt alts
  204. where
  205. (con_target, alt_env)
  206. = case scrut' of
  207. Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1]
  208. -- map: bndr -> v'
  209. _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2]
  210. -- map: scrut' -> bndr'
  211. arg_tys = tyConAppArgs (idType bndr)
  212. cse_alt (DataAlt con, args, rhs)
  213. | not (null args)
  214. -- Don't try CSE if there are no args; it just increases the number
  215. -- of live vars. E.g.
  216. -- case x of { True -> ....True.... }
  217. -- Don't replace True by x!
  218. -- Hence the 'null args', which also deal with literals and DEFAULT
  219. = (DataAlt con, args', tryForCSE new_env rhs)
  220. where
  221. (env', args') = addBinders alt_env args
  222. new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
  223. (Var con_target)
  224. cse_alt (con, args, rhs)
  225. = (con, args', tryForCSE env' rhs)
  226. where
  227. (env', args') = addBinders alt_env args
  228. \end{code}
  229. %************************************************************************
  230. %* *
  231. \section{The CSE envt}
  232. %* *
  233. %************************************************************************
  234. \begin{code}
  235. type InExpr = CoreExpr -- Pre-cloning
  236. type InBndr = CoreBndr
  237. type InAlt = CoreAlt
  238. type OutExpr = CoreExpr -- Post-cloning
  239. type OutBndr = CoreBndr
  240. type OutAlt = CoreAlt
  241. -- See Note [Keep old CsEnv rep]
  242. #ifdef OLD_CSENV_REP
  243. data CSEnv = CS { cs_map :: CSEMap
  244. , cs_subst :: Subst }
  245. type CSEMap = UniqFM [(OutExpr, OutExpr)] -- This is the reverse mapping
  246. -- It maps the hash-code of an expression e to list of (e,e') pairs
  247. -- This means that it's good to replace e by e'
  248. -- INVARIANT: The expr in the range has already been CSE'd
  249. emptyCSEnv :: CSEnv
  250. emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst }
  251. lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
  252. lookupCSEnv (CS { cs_map = oldmap, cs_subst = sub}) expr
  253. = case lookupUFM oldmap (hashExpr expr) of
  254. Nothing -> Nothing
  255. Just pairs -> lookup_list pairs
  256. where
  257. in_scope = substInScope sub
  258. -- In this lookup we use full expression equality
  259. -- Reason: when expressions differ we generally find out quickly
  260. -- but I found that cheapEqExpr was saying (\x.x) /= (\y.y),
  261. -- and this kind of thing happened in real programs
  262. lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr
  263. lookup_list ((e,e'):es)
  264. | eqExpr in_scope e expr = Just e'
  265. | otherwise = lookup_list es
  266. lookup_list [] = Nothing
  267. addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv
  268. addCSEnvItem env expr expr' | exprIsBig expr = env
  269. | otherwise = extendCSEnv env expr expr'
  270. -- We don't try to CSE big expressions, because they are expensive to compare
  271. -- (and are unlikely to be the same anyway)
  272. extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
  273. extendCSEnv cse@(CS { cs_map = oldmap }) expr expr'
  274. = cse { cs_map = addToUFM_C combine oldmap hash [(expr, expr')] }
  275. where
  276. hash = hashExpr expr
  277. combine old new
  278. = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
  279. where
  280. result = new ++ old
  281. short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
  282. long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
  283. | otherwise = empty
  284. #else
  285. ------------ NEW ----------------
  286. data CSEnv = CS { cs_map :: CoreMap (OutExpr, OutExpr) -- Key, value
  287. , cs_subst :: Subst }
  288. emptyCSEnv :: CSEnv
  289. emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
  290. lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
  291. lookupCSEnv (CS { cs_map = csmap }) expr
  292. = case lookupCoreMap csmap expr of
  293. Just (_,e) -> Just e
  294. Nothing -> Nothing
  295. addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv
  296. addCSEnvItem = extendCSEnv
  297. -- We used to avoid trying to CSE big expressions, on the grounds
  298. -- that they are expensive to compare. But now we have CoreMaps
  299. -- we can happily insert them and laziness will mean that the
  300. -- insertions only get fully done if we look up in that part
  301. -- of the trie. No need for a size test.
  302. extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
  303. extendCSEnv cse expr expr'
  304. = cse { cs_map = extendCoreMap (cs_map cse) expr (expr,expr') }
  305. #endif
  306. csEnvSubst :: CSEnv -> Subst
  307. csEnvSubst = cs_subst
  308. lookupSubst :: CSEnv -> Id -> OutExpr
  309. lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
  310. extendCSSubst :: CSEnv -> Id -> Id -> CSEnv
  311. extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) }
  312. addBinder :: CSEnv -> Var -> (CSEnv, Var)
  313. addBinder cse v = (cse { cs_subst = sub' }, v')
  314. where
  315. (sub', v') = substBndr (cs_subst cse) v
  316. addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
  317. addBinders cse vs = (cse { cs_subst = sub' }, vs')
  318. where
  319. (sub', vs') = substBndrs (cs_subst cse) vs
  320. addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
  321. addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
  322. where
  323. (sub', vs') = substRecBndrs (cs_subst cse) vs
  324. \end{code}