PageRenderTime 93ms CodeModel.GetById 34ms RepoModel.GetById 1ms app.codeStats 1ms

/compiler/specialise/SpecConstr.lhs

https://bitbucket.org/khibino/ghc-hack
Haskell | 1791 lines | 1216 code | 325 blank | 250 comment | 68 complexity | c3c472d8eb5a8635ea6915d5aedab319 MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause, LGPL-3.0

Large files files are truncated, but you can click here to view the full file

  1. ToDo [Nov 2010]
  2. ~~~~~~~~~~~~~~~
  3. 1. Use a library type rather than an annotation for ForceSpecConstr
  4. 2. Nuke NoSpecConstr
  5. %
  6. % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
  7. %
  8. \section[SpecConstr]{Specialise over constructors}
  9. \begin{code}
  10. {-# OPTIONS -fno-warn-tabs #-}
  11. -- The above warning supression flag is a temporary kludge.
  12. -- While working on this module you are encouraged to remove it and
  13. -- detab the module (please do the detabbing in a separate patch). See
  14. -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
  15. -- for details
  16. module SpecConstr(
  17. specConstrProgram
  18. #ifdef GHCI
  19. , SpecConstrAnnotation(..)
  20. #endif
  21. ) where
  22. #include "HsVersions.h"
  23. import CoreSyn
  24. import CoreSubst
  25. import CoreUtils
  26. import CoreUnfold ( couldBeSmallEnoughToInline )
  27. import CoreFVs ( exprsFreeVars )
  28. import CoreMonad
  29. import Literal ( litIsLifted )
  30. import HscTypes ( ModGuts(..) )
  31. import WwLib ( mkWorkerArgs )
  32. import DataCon
  33. import Coercion hiding( substTy, substCo )
  34. import Rules
  35. import Type hiding ( substTy )
  36. import Id
  37. import MkCore ( mkImpossibleExpr )
  38. import Var
  39. import VarEnv
  40. import VarSet
  41. import Name
  42. import BasicTypes
  43. import DynFlags ( DynFlags(..) )
  44. import StaticFlags ( opt_PprStyle_Debug )
  45. import Maybes ( orElse, catMaybes, isJust, isNothing )
  46. import Demand
  47. import DmdAnal ( both )
  48. import Serialized ( deserializeWithData )
  49. import Util
  50. import Pair
  51. import UniqSupply
  52. import Outputable
  53. import FastString
  54. import UniqFM
  55. import MonadUtils
  56. import Control.Monad ( zipWithM )
  57. import Data.List
  58. -- See Note [SpecConstrAnnotation]
  59. #ifndef GHCI
  60. type SpecConstrAnnotation = ()
  61. #else
  62. import TyCon ( TyCon )
  63. import GHC.Exts( SpecConstrAnnotation(..) )
  64. #endif
  65. \end{code}
  66. -----------------------------------------------------
  67. Game plan
  68. -----------------------------------------------------
  69. Consider
  70. drop n [] = []
  71. drop 0 xs = []
  72. drop n (x:xs) = drop (n-1) xs
  73. After the first time round, we could pass n unboxed. This happens in
  74. numerical code too. Here's what it looks like in Core:
  75. drop n xs = case xs of
  76. [] -> []
  77. (y:ys) -> case n of
  78. I# n# -> case n# of
  79. 0 -> []
  80. _ -> drop (I# (n# -# 1#)) xs
  81. Notice that the recursive call has an explicit constructor as argument.
  82. Noticing this, we can make a specialised version of drop
  83. RULE: drop (I# n#) xs ==> drop' n# xs
  84. drop' n# xs = let n = I# n# in ...orig RHS...
  85. Now the simplifier will apply the specialisation in the rhs of drop', giving
  86. drop' n# xs = case xs of
  87. [] -> []
  88. (y:ys) -> case n# of
  89. 0 -> []
  90. _ -> drop (n# -# 1#) xs
  91. Much better!
  92. We'd also like to catch cases where a parameter is carried along unchanged,
  93. but evaluated each time round the loop:
  94. f i n = if i>0 || i>n then i else f (i*2) n
  95. Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
  96. In Core, by the time we've w/wd (f is strict in i) we get
  97. f i# n = case i# ># 0 of
  98. False -> I# i#
  99. True -> case n of n' { I# n# ->
  100. case i# ># n# of
  101. False -> I# i#
  102. True -> f (i# *# 2#) n'
  103. At the call to f, we see that the argument, n is know to be (I# n#),
  104. and n is evaluated elsewhere in the body of f, so we can play the same
  105. trick as above.
  106. Note [Reboxing]
  107. ~~~~~~~~~~~~~~~
  108. We must be careful not to allocate the same constructor twice. Consider
  109. f p = (...(case p of (a,b) -> e)...p...,
  110. ...let t = (r,s) in ...t...(f t)...)
  111. At the recursive call to f, we can see that t is a pair. But we do NOT want
  112. to make a specialised copy:
  113. f' a b = let p = (a,b) in (..., ...)
  114. because now t is allocated by the caller, then r and s are passed to the
  115. recursive call, which allocates the (r,s) pair again.
  116. This happens if
  117. (a) the argument p is used in other than a case-scrutinsation way.
  118. (b) the argument to the call is not a 'fresh' tuple; you have to
  119. look into its unfolding to see that it's a tuple
  120. Hence the "OR" part of Note [Good arguments] below.
  121. ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
  122. allocation, but does perhaps save evals. In the RULE we'd have
  123. something like
  124. f (I# x#) = f' (I# x#) x#
  125. If at the call site the (I# x) was an unfolding, then we'd have to
  126. rely on CSE to eliminate the duplicate allocation.... This alternative
  127. doesn't look attractive enough to pursue.
  128. ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
  129. the conservative reboxing story prevents many useful functions from being
  130. specialised. Example:
  131. foo :: Maybe Int -> Int -> Int
  132. foo (Just m) 0 = 0
  133. foo x@(Just m) n = foo x (n-m)
  134. Here the use of 'x' will clearly not require boxing in the specialised function.
  135. The strictness analyser has the same problem, in fact. Example:
  136. f p@(a,b) = ...
  137. If we pass just 'a' and 'b' to the worker, it might need to rebox the
  138. pair to create (a,b). A more sophisticated analysis might figure out
  139. precisely the cases in which this could happen, but the strictness
  140. analyser does no such analysis; it just passes 'a' and 'b', and hopes
  141. for the best.
  142. So my current choice is to make SpecConstr similarly aggressive, and
  143. ignore the bad potential of reboxing.
  144. Note [Good arguments]
  145. ~~~~~~~~~~~~~~~~~~~~~
  146. So we look for
  147. * A self-recursive function. Ignore mutual recursion for now,
  148. because it's less common, and the code is simpler for self-recursion.
  149. * EITHER
  150. a) At a recursive call, one or more parameters is an explicit
  151. constructor application
  152. AND
  153. That same parameter is scrutinised by a case somewhere in
  154. the RHS of the function
  155. OR
  156. b) At a recursive call, one or more parameters has an unfolding
  157. that is an explicit constructor application
  158. AND
  159. That same parameter is scrutinised by a case somewhere in
  160. the RHS of the function
  161. AND
  162. Those are the only uses of the parameter (see Note [Reboxing])
  163. What to abstract over
  164. ~~~~~~~~~~~~~~~~~~~~~
  165. There's a bit of a complication with type arguments. If the call
  166. site looks like
  167. f p = ...f ((:) [a] x xs)...
  168. then our specialised function look like
  169. f_spec x xs = let p = (:) [a] x xs in ....as before....
  170. This only makes sense if either
  171. a) the type variable 'a' is in scope at the top of f, or
  172. b) the type variable 'a' is an argument to f (and hence fs)
  173. Actually, (a) may hold for value arguments too, in which case
  174. we may not want to pass them. Supose 'x' is in scope at f's
  175. defn, but xs is not. Then we'd like
  176. f_spec xs = let p = (:) [a] x xs in ....as before....
  177. Similarly (b) may hold too. If x is already an argument at the
  178. call, no need to pass it again.
  179. Finally, if 'a' is not in scope at the call site, we could abstract
  180. it as we do the term variables:
  181. f_spec a x xs = let p = (:) [a] x xs in ...as before...
  182. So the grand plan is:
  183. * abstract the call site to a constructor-only pattern
  184. e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
  185. * Find the free variables of the abstracted pattern
  186. * Pass these variables, less any that are in scope at
  187. the fn defn. But see Note [Shadowing] below.
  188. NOTICE that we only abstract over variables that are not in scope,
  189. so we're in no danger of shadowing variables used in "higher up"
  190. in f_spec's RHS.
  191. Note [Shadowing]
  192. ~~~~~~~~~~~~~~~~
  193. In this pass we gather up usage information that may mention variables
  194. that are bound between the usage site and the definition site; or (more
  195. seriously) may be bound to something different at the definition site.
  196. For example:
  197. f x = letrec g y v = let x = ...
  198. in ...(g (a,b) x)...
  199. Since 'x' is in scope at the call site, we may make a rewrite rule that
  200. looks like
  201. RULE forall a,b. g (a,b) x = ...
  202. But this rule will never match, because it's really a different 'x' at
  203. the call site -- and that difference will be manifest by the time the
  204. simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
  205. no-shadowing, so perhaps it may not be distinct?]
  206. Anyway, the rule isn't actually wrong, it's just not useful. One possibility
  207. is to run deShadowBinds before running SpecConstr, but instead we run the
  208. simplifier. That gives the simplest possible program for SpecConstr to
  209. chew on; and it virtually guarantees no shadowing.
  210. Note [Specialising for constant parameters]
  211. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  212. This one is about specialising on a *constant* (but not necessarily
  213. constructor) argument
  214. foo :: Int -> (Int -> Int) -> Int
  215. foo 0 f = 0
  216. foo m f = foo (f m) (+1)
  217. It produces
  218. lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
  219. lvl_rmV =
  220. \ (ds_dlk :: GHC.Base.Int) ->
  221. case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
  222. GHC.Base.I# (GHC.Prim.+# x_alG 1)
  223. T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
  224. GHC.Prim.Int#
  225. T.$wfoo =
  226. \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
  227. case ww_sme of ds_Xlw {
  228. __DEFAULT ->
  229. case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
  230. T.$wfoo ww1_Xmz lvl_rmV
  231. };
  232. 0 -> 0
  233. }
  234. The recursive call has lvl_rmV as its argument, so we could create a specialised copy
  235. with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
  236. When is this worth it? Call the constant 'lvl'
  237. - If 'lvl' has an unfolding that is a constructor, see if the corresponding
  238. parameter is scrutinised anywhere in the body.
  239. - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
  240. parameter is applied (...to enough arguments...?)
  241. Also do this is if the function has RULES?
  242. Also
  243. Note [Specialising for lambda parameters]
  244. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  245. foo :: Int -> (Int -> Int) -> Int
  246. foo 0 f = 0
  247. foo m f = foo (f m) (\n -> n-m)
  248. This is subtly different from the previous one in that we get an
  249. explicit lambda as the argument:
  250. T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
  251. GHC.Prim.Int#
  252. T.$wfoo =
  253. \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
  254. case ww_sm8 of ds_Xlr {
  255. __DEFAULT ->
  256. case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
  257. T.$wfoo
  258. ww1_Xmq
  259. (\ (n_ad3 :: GHC.Base.Int) ->
  260. case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
  261. GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
  262. })
  263. };
  264. 0 -> 0
  265. }
  266. I wonder if SpecConstr couldn't be extended to handle this? After all,
  267. lambda is a sort of constructor for functions and perhaps it already
  268. has most of the necessary machinery?
  269. Furthermore, there's an immediate win, because you don't need to allocate the lamda
  270. at the call site; and if perchance it's called in the recursive call, then you
  271. may avoid allocating it altogether. Just like for constructors.
  272. Looks cool, but probably rare...but it might be easy to implement.
  273. Note [SpecConstr for casts]
  274. ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  275. Consider
  276. data family T a :: *
  277. data instance T Int = T Int
  278. foo n = ...
  279. where
  280. go (T 0) = 0
  281. go (T n) = go (T (n-1))
  282. The recursive call ends up looking like
  283. go (T (I# ...) `cast` g)
  284. So we want to spot the construtor application inside the cast.
  285. That's why we have the Cast case in argToPat
  286. Note [Local recursive groups]
  287. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  288. For a *local* recursive group, we can see all the calls to the
  289. function, so we seed the specialisation loop from the calls in the
  290. body, not from the calls in the RHS. Consider:
  291. bar m n = foo n (n,n) (n,n) (n,n) (n,n)
  292. where
  293. foo n p q r s
  294. | n == 0 = m
  295. | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
  296. | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
  297. | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
  298. | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
  299. If we start with the RHSs of 'foo', we get lots and lots of specialisations,
  300. most of which are not needed. But if we start with the (single) call
  301. in the rhs of 'bar' we get exactly one fully-specialised copy, and all
  302. the recursive calls go to this fully-specialised copy. Indeed, the original
  303. function is later collected as dead code. This is very important in
  304. specialising the loops arising from stream fusion, for example in NDP where
  305. we were getting literally hundreds of (mostly unused) specialisations of
  306. a local function.
  307. In a case like the above we end up never calling the original un-specialised
  308. function. (Although we still leave its code around just in case.)
  309. However, if we find any boring calls in the body, including *unsaturated*
  310. ones, such as
  311. letrec foo x y = ....foo...
  312. in map foo xs
  313. then we will end up calling the un-specialised function, so then we *should*
  314. use the calls in the un-specialised RHS as seeds. We call these "boring
  315. call patterns, and callsToPats reports if it finds any of these.
  316. Note [Do not specialise diverging functions]
  317. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  318. Specialising a function that just diverges is a waste of code.
  319. Furthermore, it broke GHC (simpl014) thus:
  320. {-# STR Sb #-}
  321. f = \x. case x of (a,b) -> f x
  322. If we specialise f we get
  323. f = \x. case x of (a,b) -> fspec a b
  324. But fspec doesn't have decent strictnes info. As it happened,
  325. (f x) :: IO t, so the state hack applied and we eta expanded fspec,
  326. and hence f. But now f's strictness is less than its arity, which
  327. breaks an invariant.
  328. Note [SpecConstrAnnotation]
  329. ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  330. SpecConstrAnnotation is defined in GHC.Exts, and is only guaranteed to
  331. be available in stage 2 (well, until the bootstrap compiler can be
  332. guaranteed to have it)
  333. So we define it to be () in stage1 (ie when GHCI is undefined), and
  334. '#ifdef' out the code that uses it.
  335. See also Note [Forcing specialisation]
  336. Note [Forcing specialisation]
  337. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  338. With stream fusion and in other similar cases, we want to fully specialise
  339. some (but not necessarily all!) loops regardless of their size and the
  340. number of specialisations. We allow a library to specify this by annotating
  341. a type with ForceSpecConstr and then adding a parameter of that type to the
  342. loop. Here is a (simplified) example from the vector library:
  343. data SPEC = SPEC | SPEC2
  344. {-# ANN type SPEC ForceSpecConstr #-}
  345. foldl :: (a -> b -> a) -> a -> Stream b -> a
  346. {-# INLINE foldl #-}
  347. foldl f z (Stream step s _) = foldl_loop SPEC z s
  348. where
  349. foldl_loop !sPEC z s = case step s of
  350. Yield x s' -> foldl_loop sPEC (f z x) s'
  351. Skip -> foldl_loop sPEC z s'
  352. Done -> z
  353. SpecConstr will spot the SPEC parameter and always fully specialise
  354. foldl_loop. Note that
  355. * We have to prevent the SPEC argument from being removed by
  356. w/w which is why (a) SPEC is a sum type, and (b) we have to seq on
  357. the SPEC argument.
  358. * And lastly, the SPEC argument is ultimately eliminated by
  359. SpecConstr itself so there is no runtime overhead.
  360. This is all quite ugly; we ought to come up with a better design.
  361. ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
  362. sc_force to True when calling specLoop. This flag does three things:
  363. * Ignore specConstrThreshold, to specialise functions of arbitrary size
  364. (see scTopBind)
  365. * Ignore specConstrCount, to make arbitrary numbers of specialisations
  366. (see specialise)
  367. * Specialise even for arguments that are not scrutinised in the loop
  368. (see argToPat; Trac #4488)
  369. This flag is inherited for nested non-recursive bindings (which are likely to
  370. be join points and hence should be fully specialised) but reset for nested
  371. recursive bindings.
  372. What alternatives did I consider? Annotating the loop itself doesn't
  373. work because (a) it is local and (b) it will be w/w'ed and I having
  374. w/w propagating annotation somehow doesn't seem like a good idea. The
  375. types of the loop arguments really seem to be the most persistent
  376. thing.
  377. Annotating the types that make up the loop state doesn't work,
  378. either, because (a) it would prevent us from using types like Either
  379. or tuples here, (b) we don't want to restrict the set of types that
  380. can be used in Stream states and (c) some types are fixed by the user
  381. (e.g., the accumulator here) but we still want to specialise as much
  382. as possible.
  383. ForceSpecConstr is done by way of an annotation:
  384. data SPEC = SPEC | SPEC2
  385. {-# ANN type SPEC ForceSpecConstr #-}
  386. But SPEC is the *only* type so annotated, so it'd be better to
  387. use a particular library type.
  388. Alternatives to ForceSpecConstr
  389. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  390. Instead of giving the loop an extra argument of type SPEC, we
  391. also considered *wrapping* arguments in SPEC, thus
  392. data SPEC a = SPEC a | SPEC2
  393. loop = \arg -> case arg of
  394. SPEC state ->
  395. case state of (x,y) -> ... loop (SPEC (x',y')) ...
  396. S2 -> error ...
  397. The idea is that a SPEC argument says "specialise this argument
  398. regardless of whether the function case-analyses it. But this
  399. doesn't work well:
  400. * SPEC must still be a sum type, else the strictness analyser
  401. eliminates it
  402. * But that means that 'loop' won't be strict in its real payload
  403. This loss of strictness in turn screws up specialisation, because
  404. we may end up with calls like
  405. loop (SPEC (case z of (p,q) -> (q,p)))
  406. Without the SPEC, if 'loop' was strict, the case would move out
  407. and we'd see loop applied to a pair. But if 'loop' isn' strict
  408. this doesn't look like a specialisable call.
  409. Note [NoSpecConstr]
  410. ~~~~~~~~~~~~~~~~~~~
  411. The ignoreDataCon stuff allows you to say
  412. {-# ANN type T NoSpecConstr #-}
  413. to mean "don't specialise on arguments of this type. It was added
  414. before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised
  415. regardless of size; and then we needed a way to turn that *off*. Now
  416. that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
  417. (Used only for PArray.)
  418. -----------------------------------------------------
  419. Stuff not yet handled
  420. -----------------------------------------------------
  421. Here are notes arising from Roman's work that I don't want to lose.
  422. Example 1
  423. ~~~~~~~~~
  424. data T a = T !a
  425. foo :: Int -> T Int -> Int
  426. foo 0 t = 0
  427. foo x t | even x = case t of { T n -> foo (x-n) t }
  428. | otherwise = foo (x-1) t
  429. SpecConstr does no specialisation, because the second recursive call
  430. looks like a boxed use of the argument. A pity.
  431. $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
  432. $wfoo_sFw =
  433. \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
  434. case ww_sFo of ds_Xw6 [Just L] {
  435. __DEFAULT ->
  436. case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
  437. __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
  438. 0 ->
  439. case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
  440. case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
  441. $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
  442. } } };
  443. 0 -> 0
  444. Example 2
  445. ~~~~~~~~~
  446. data a :*: b = !a :*: !b
  447. data T a = T !a
  448. foo :: (Int :*: T Int) -> Int
  449. foo (0 :*: t) = 0
  450. foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
  451. | otherwise = foo ((x-1) :*: t)
  452. Very similar to the previous one, except that the parameters are now in
  453. a strict tuple. Before SpecConstr, we have
  454. $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
  455. $wfoo_sG3 =
  456. \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
  457. GHC.Base.Int) ->
  458. case ww_sFU of ds_Xws [Just L] {
  459. __DEFAULT ->
  460. case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
  461. __DEFAULT ->
  462. case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
  463. $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
  464. };
  465. 0 ->
  466. case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
  467. case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
  468. $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
  469. } } };
  470. 0 -> 0 }
  471. We get two specialisations:
  472. "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
  473. Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
  474. = Foo.$s$wfoo1 a_sFB sc_sGC ;
  475. "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
  476. Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
  477. = Foo.$s$wfoo y_aFp sc_sGC ;
  478. But perhaps the first one isn't good. After all, we know that tpl_B2 is
  479. a T (I# x) really, because T is strict and Int has one constructor. (We can't
  480. unbox the strict fields, becuase T is polymorphic!)
  481. %************************************************************************
  482. %* *
  483. \subsection{Top level wrapper stuff}
  484. %* *
  485. %************************************************************************
  486. \begin{code}
  487. specConstrProgram :: ModGuts -> CoreM ModGuts
  488. specConstrProgram guts
  489. = do
  490. dflags <- getDynFlags
  491. us <- getUniqueSupplyM
  492. annos <- getFirstAnnotations deserializeWithData guts
  493. let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
  494. return (guts { mg_binds = binds' })
  495. where
  496. go _ [] = return []
  497. go env (bind:binds) = do (env', bind') <- scTopBind env bind
  498. binds' <- go env' binds
  499. return (bind' : binds')
  500. \end{code}
  501. %************************************************************************
  502. %* *
  503. \subsection{Environment: goes downwards}
  504. %* *
  505. %************************************************************************
  506. \begin{code}
  507. data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
  508. sc_count :: Maybe Int, -- Max # of specialisations for any one fn
  509. -- See Note [Avoiding exponential blowup]
  510. sc_force :: Bool, -- Force specialisation?
  511. -- See Note [Forcing specialisation]
  512. sc_subst :: Subst, -- Current substitution
  513. -- Maps InIds to OutExprs
  514. sc_how_bound :: HowBoundEnv,
  515. -- Binds interesting non-top-level variables
  516. -- Domain is OutVars (*after* applying the substitution)
  517. sc_vals :: ValueEnv,
  518. -- Domain is OutIds (*after* applying the substitution)
  519. -- Used even for top-level bindings (but not imported ones)
  520. sc_annotations :: UniqFM SpecConstrAnnotation
  521. }
  522. ---------------------
  523. -- As we go, we apply a substitution (sc_subst) to the current term
  524. type InExpr = CoreExpr -- _Before_ applying the subst
  525. type InVar = Var
  526. type OutExpr = CoreExpr -- _After_ applying the subst
  527. type OutId = Id
  528. type OutVar = Var
  529. ---------------------
  530. type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
  531. ---------------------
  532. type ValueEnv = IdEnv Value -- Domain is OutIds
  533. data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
  534. -- The AltCon is never DEFAULT
  535. | LambdaVal -- Inlinable lambdas or PAPs
  536. instance Outputable Value where
  537. ppr (ConVal con args) = ppr con <+> interpp'SP args
  538. ppr LambdaVal = ptext (sLit "<Lambda>")
  539. ---------------------
  540. initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
  541. initScEnv dflags anns
  542. = SCE { sc_size = specConstrThreshold dflags,
  543. sc_count = specConstrCount dflags,
  544. sc_force = False,
  545. sc_subst = emptySubst,
  546. sc_how_bound = emptyVarEnv,
  547. sc_vals = emptyVarEnv,
  548. sc_annotations = anns }
  549. data HowBound = RecFun -- These are the recursive functions for which
  550. -- we seek interesting call patterns
  551. | RecArg -- These are those functions' arguments, or their sub-components;
  552. -- we gather occurrence information for these
  553. instance Outputable HowBound where
  554. ppr RecFun = text "RecFun"
  555. ppr RecArg = text "RecArg"
  556. scForce :: ScEnv -> Bool -> ScEnv
  557. scForce env b = env { sc_force = b }
  558. lookupHowBound :: ScEnv -> Id -> Maybe HowBound
  559. lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
  560. scSubstId :: ScEnv -> Id -> CoreExpr
  561. scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
  562. scSubstTy :: ScEnv -> Type -> Type
  563. scSubstTy env ty = substTy (sc_subst env) ty
  564. scSubstCo :: ScEnv -> Coercion -> Coercion
  565. scSubstCo env co = substCo (sc_subst env) co
  566. zapScSubst :: ScEnv -> ScEnv
  567. zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
  568. extendScInScope :: ScEnv -> [Var] -> ScEnv
  569. -- Bring the quantified variables into scope
  570. extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
  571. -- Extend the substitution
  572. extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
  573. extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
  574. extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
  575. extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
  576. extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
  577. extendHowBound env bndrs how_bound
  578. = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
  579. [(bndr,how_bound) | bndr <- bndrs] }
  580. extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
  581. extendBndrsWith how_bound env bndrs
  582. = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
  583. where
  584. (subst', bndrs') = substBndrs (sc_subst env) bndrs
  585. hb_env' = sc_how_bound env `extendVarEnvList`
  586. [(bndr,how_bound) | bndr <- bndrs']
  587. extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
  588. extendBndrWith how_bound env bndr
  589. = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
  590. where
  591. (subst', bndr') = substBndr (sc_subst env) bndr
  592. hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
  593. extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
  594. extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
  595. where
  596. (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
  597. extendBndr :: ScEnv -> Var -> (ScEnv, Var)
  598. extendBndr env bndr = (env { sc_subst = subst' }, bndr')
  599. where
  600. (subst', bndr') = substBndr (sc_subst env) bndr
  601. extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
  602. extendValEnv env _ Nothing = env
  603. extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
  604. extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])
  605. -- When we encounter
  606. -- case scrut of b
  607. -- C x y -> ...
  608. -- we want to bind b, to (C x y)
  609. -- NB1: Extends only the sc_vals part of the envt
  610. -- NB2: Kill the dead-ness info on the pattern binders x,y, since
  611. -- they are potentially made alive by the [b -> C x y] binding
  612. extendCaseBndrs env scrut case_bndr con alt_bndrs
  613. = (env2, alt_bndrs')
  614. where
  615. live_case_bndr = not (isDeadBinder case_bndr)
  616. env1 | Var v <- scrut = extendValEnv env v cval
  617. | otherwise = env -- See Note [Add scrutinee to ValueEnv too]
  618. env2 | live_case_bndr = extendValEnv env1 case_bndr cval
  619. | otherwise = env1
  620. alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }
  621. = map zap alt_bndrs
  622. | otherwise
  623. = alt_bndrs
  624. cval = case con of
  625. DEFAULT -> Nothing
  626. LitAlt {} -> Just (ConVal con [])
  627. DataAlt {} -> Just (ConVal con vanilla_args)
  628. where
  629. vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
  630. varsToCoreExprs alt_bndrs
  631. zap v | isTyVar v = v -- See NB2 above
  632. | otherwise = zapIdOccInfo v
  633. decreaseSpecCount :: ScEnv -> Int -> ScEnv
  634. -- See Note [Avoiding exponential blowup]
  635. decreaseSpecCount env n_specs
  636. = env { sc_count = case sc_count env of
  637. Nothing -> Nothing
  638. Just n -> Just (n `div` (n_specs + 1)) }
  639. -- The "+1" takes account of the original function;
  640. -- See Note [Avoiding exponential blowup]
  641. ---------------------------------------------------
  642. -- See Note [SpecConstrAnnotation]
  643. ignoreType :: ScEnv -> Type -> Bool
  644. ignoreDataCon :: ScEnv -> DataCon -> Bool
  645. forceSpecBndr :: ScEnv -> Var -> Bool
  646. #ifndef GHCI
  647. ignoreType _ _ = False
  648. ignoreDataCon _ _ = False
  649. forceSpecBndr _ _ = False
  650. #else /* GHCI */
  651. ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
  652. ignoreType env ty
  653. = case tyConAppTyCon_maybe ty of
  654. Just tycon -> ignoreTyCon env tycon
  655. _ -> False
  656. ignoreTyCon :: ScEnv -> TyCon -> Bool
  657. ignoreTyCon env tycon
  658. = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
  659. forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
  660. forceSpecFunTy :: ScEnv -> Type -> Bool
  661. forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
  662. forceSpecArgTy :: ScEnv -> Type -> Bool
  663. forceSpecArgTy env ty
  664. | Just ty' <- coreView ty = forceSpecArgTy env ty'
  665. forceSpecArgTy env ty
  666. | Just (tycon, tys) <- splitTyConApp_maybe ty
  667. , tycon /= funTyCon
  668. = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
  669. || any (forceSpecArgTy env) tys
  670. forceSpecArgTy _ _ = False
  671. #endif /* GHCI */
  672. \end{code}
  673. Note [Add scrutinee to ValueEnv too]
  674. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  675. Consider this:
  676. case x of y
  677. (a,b) -> case b of c
  678. I# v -> ...(f y)...
  679. By the time we get to the call (f y), the ValueEnv
  680. will have a binding for y, and for c
  681. y -> (a,b)
  682. c -> I# v
  683. BUT that's not enough! Looking at the call (f y) we
  684. see that y is pair (a,b), but we also need to know what 'b' is.
  685. So in extendCaseBndrs we must *also* add the binding
  686. b -> I# v
  687. else we lose a useful specialisation for f. This is necessary even
  688. though the simplifier has systematically replaced uses of 'x' with 'y'
  689. and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came
  690. from outside the case. See Trac #4908 for the live example.
  691. Note [Avoiding exponential blowup]
  692. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  693. The sc_count field of the ScEnv says how many times we are prepared to
  694. duplicate a single function. But we must take care with recursive
  695. specialiations. Consider
  696. let $j1 = let $j2 = let $j3 = ...
  697. in
  698. ...$j3...
  699. in
  700. ...$j2...
  701. in
  702. ...$j1...
  703. If we specialise $j1 then in each specialisation (as well as the original)
  704. we can specialise $j2, and similarly $j3. Even if we make just *one*
  705. specialisation of each, becuase we also have the original we'll get 2^n
  706. copies of $j3, which is not good.
  707. So when recursively specialising we divide the sc_count by the number of
  708. copies we are making at this level, including the original.
  709. %************************************************************************
  710. %* *
  711. \subsection{Usage information: flows upwards}
  712. %* *
  713. %************************************************************************
  714. \begin{code}
  715. data ScUsage
  716. = SCU {
  717. scu_calls :: CallEnv, -- Calls
  718. -- The functions are a subset of the
  719. -- RecFuns in the ScEnv
  720. scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
  721. } -- The domain is OutIds
  722. type CallEnv = IdEnv [Call]
  723. type Call = (ValueEnv, [CoreArg])
  724. -- The arguments of the call, together with the
  725. -- env giving the constructor bindings at the call site
  726. nullUsage :: ScUsage
  727. nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
  728. combineCalls :: CallEnv -> CallEnv -> CallEnv
  729. combineCalls = plusVarEnv_C (++)
  730. combineUsage :: ScUsage -> ScUsage -> ScUsage
  731. combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
  732. scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
  733. combineUsages :: [ScUsage] -> ScUsage
  734. combineUsages [] = nullUsage
  735. combineUsages us = foldr1 combineUsage us
  736. lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
  737. lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
  738. = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
  739. [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
  740. data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
  741. | UnkOcc -- Used in some unknown way
  742. | ScrutOcc -- See Note [ScrutOcc]
  743. (DataConEnv [ArgOcc]) -- How the sub-components are used
  744. type DataConEnv a = UniqFM a -- Keyed by DataCon
  745. {- Note [ScrutOcc]
  746. ~~~~~~~~~~~~~~~~~~~
  747. An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
  748. is *only* taken apart or applied.
  749. Functions, literal: ScrutOcc emptyUFM
  750. Data constructors: ScrutOcc subs,
  751. where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
  752. The domain of the UniqFM is the Unique of the data constructor
  753. The [ArgOcc] is the occurrences of the *pattern-bound* components
  754. of the data structure. E.g.
  755. data T a = forall b. MkT a b (b->a)
  756. A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
  757. -}
  758. instance Outputable ArgOcc where
  759. ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
  760. ppr UnkOcc = ptext (sLit "unk-occ")
  761. ppr NoOcc = ptext (sLit "no-occ")
  762. evalScrutOcc :: ArgOcc
  763. evalScrutOcc = ScrutOcc emptyUFM
  764. -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
  765. -- that if the thing is scrutinised anywhere then we get to see that
  766. -- in the overall result, even if it's also used in a boxed way
  767. -- This might be too agressive; see Note [Reboxing] Alternative 3
  768. combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
  769. combineOcc NoOcc occ = occ
  770. combineOcc occ NoOcc = occ
  771. combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
  772. combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys
  773. combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs
  774. combineOcc UnkOcc UnkOcc = UnkOcc
  775. combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
  776. combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
  777. setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
  778. -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
  779. -- is a variable, and an interesting variable
  780. setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
  781. setScrutOcc env usg (Tick _ e) occ = setScrutOcc env usg e occ
  782. setScrutOcc env usg (Var v) occ
  783. | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
  784. | otherwise = usg
  785. setScrutOcc _env usg _other _occ -- Catch-all
  786. = usg
  787. \end{code}
  788. %************************************************************************
  789. %* *
  790. \subsection{The main recursive function}
  791. %* *
  792. %************************************************************************
  793. The main recursive function gathers up usage information, and
  794. creates specialised versions of functions.
  795. \begin{code}
  796. scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
  797. -- The unique supply is needed when we invent
  798. -- a new name for the specialised function and its args
  799. scExpr env e = scExpr' env e
  800. scExpr' env (Var v) = case scSubstId env v of
  801. Var v' -> return (mkVarUsage env v' [], Var v')
  802. e' -> scExpr (zapScSubst env) e'
  803. scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
  804. scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
  805. scExpr' _ e@(Lit {}) = return (nullUsage, e)
  806. scExpr' env (Tick t e) = do (usg,e') <- scExpr env e
  807. return (usg, Tick t e')
  808. scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
  809. return (usg, Cast e' (scSubstCo env co))
  810. scExpr' env e@(App _ _) = scApp env (collectArgs e)
  811. scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
  812. (usg, e') <- scExpr env' e
  813. return (usg, Lam b' e')
  814. scExpr' env (Case scrut b ty alts)
  815. = do { (scrut_usg, scrut') <- scExpr env scrut
  816. ; case isValue (sc_vals env) scrut' of
  817. Just (ConVal con args) -> sc_con_app con args scrut'
  818. _other -> sc_vanilla scrut_usg scrut'
  819. }
  820. where
  821. sc_con_app con args scrut' -- Known constructor; simplify
  822. = do { let (_, bs, rhs) = findAlt con alts
  823. `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
  824. alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
  825. ; scExpr alt_env' rhs }
  826. sc_vanilla scrut_usg scrut' -- Normal case
  827. = do { let (alt_env,b') = extendBndrWith RecArg env b
  828. -- Record RecArg for the components
  829. ; (alt_usgs, alt_occs, alts')
  830. <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
  831. ; let scrut_occ = foldr1 combineOcc alt_occs -- Never empty
  832. scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
  833. -- The combined usage of the scrutinee is given
  834. -- by scrut_occ, which is passed to scScrut, which
  835. -- in turn treats a bare-variable scrutinee specially
  836. ; return (foldr combineUsage scrut_usg' alt_usgs,
  837. Case scrut' b' (scSubstTy env ty) alts') }
  838. sc_alt env scrut' b' (con,bs,rhs)
  839. = do { let (env1, bs1) = extendBndrsWith RecArg env bs
  840. (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1
  841. ; (usg, rhs') <- scExpr env2 rhs
  842. ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
  843. scrut_occ = case con of
  844. DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
  845. _ -> ScrutOcc emptyUFM
  846. ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
  847. scExpr' env (Let (NonRec bndr rhs) body)
  848. | isTyVar bndr -- Type-lets may be created by doBeta
  849. = scExpr' (extendScSubst env bndr rhs) body
  850. | otherwise
  851. = do { let (body_env, bndr') = extendBndr env bndr
  852. ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
  853. ; let body_env2 = extendHowBound body_env [bndr'] RecFun
  854. -- Note [Local let bindings]
  855. RI _ rhs' _ _ _ = rhs_info
  856. body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
  857. ; (body_usg, body') <- scExpr body_env3 body
  858. -- NB: For non-recursive bindings we inherit sc_force flag from
  859. -- the parent function (see Note [Forcing specialisation])
  860. ; (spec_usg, specs) <- specialise env
  861. (scu_calls body_usg)
  862. rhs_info
  863. (SI [] 0 (Just rhs_usg))
  864. ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
  865. `combineUsage` rhs_usg `combineUsage` spec_usg,
  866. mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
  867. }
  868. -- A *local* recursive group: see Note [Local recursive groups]
  869. scExpr' env (Let (Rec prs) body)
  870. = do { let (bndrs,rhss) = unzip prs
  871. (rhs_env1,bndrs') = extendRecBndrs env bndrs
  872. rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
  873. force_spec = any (forceSpecBndr env) bndrs'
  874. -- Note [Forcing specialisation]
  875. ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
  876. ; (body_usg, body') <- scExpr rhs_env2 body
  877. -- NB: start specLoop from body_usg
  878. ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec)
  879. (scu_calls body_usg) rhs_infos nullUsage
  880. [SI [] 0 (Just usg) | usg <- rhs_usgs]
  881. -- Do not unconditionally generate specialisations from rhs_usgs
  882. -- Instead use them only if we find an unspecialised call
  883. -- See Note [Local recursive groups]
  884. ; let rhs_usg = combineUsages rhs_usgs
  885. all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg
  886. bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
  887. ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
  888. Let bind' body') }
  889. \end{code}
  890. Note [Local let bindings]
  891. ~~~~~~~~~~~~~~~~~~~~~~~~~
  892. It is not uncommon to find this
  893. let $j = \x. <blah> in ...$j True...$j True...
  894. Here $j is an arbitrary let-bound function, but it often comes up for
  895. join points. We might like to specialise $j for its call patterns.
  896. Notice the difference from a letrec, where we look for call patterns
  897. in the *RHS* of the function. Here we look for call patterns in the
  898. *body* of the let.
  899. At one point I predicated this on the RHS mentioning the outer
  900. recursive function, but that's not essential and might even be
  901. harmful. I'm not sure.
  902. \begin{code}
  903. scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
  904. scApp env (Var fn, args) -- Function is a variable
  905. = ASSERT( not (null args) )
  906. do { args_w_usgs <- mapM (scExpr env) args
  907. ; let (arg_usgs, args') = unzip args_w_usgs
  908. arg_usg = combineUsages arg_usgs
  909. ; case scSubstId env fn of
  910. fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
  911. -- Do beta-reduction and try again
  912. Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',
  913. mkApps (Var fn') args')
  914. other_fn' -> return (arg_usg, mkApps other_fn' args') }
  915. -- NB: doing this ignores any usage info from the substituted
  916. -- function, but I don't think that matters. If it does
  917. -- we can fix it.
  918. where
  919. doBeta :: OutExpr -> [OutExpr] -> OutExpr
  920. -- ToDo: adjust for System IF
  921. doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
  922. doBeta fn args = mkApps fn args
  923. -- The function is almost always a variable, but not always.
  924. -- In particular, if this pass follows float-in,
  925. -- which it may, we can get
  926. -- (let f = ...f... in f) arg1 arg2
  927. scApp env (other_fn, args)
  928. = do { (fn_usg, fn') <- scExpr env other_fn
  929. ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
  930. ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
  931. ----------------------
  932. mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
  933. mkVarUsage env fn args
  934. = case lookupHowBound env fn of
  935. Just RecFun -> SCU { scu_calls = unitVarEnv fn [(sc_vals env, args)]
  936. , scu_occs = emptyVarEnv }
  937. Just RecArg -> SCU { scu_calls = emptyVarEnv
  938. , scu_occs = unitVarEnv fn arg_occ }
  939. Nothing -> nullUsage
  940. where
  941. -- I rather think we could use UnkOcc all the time
  942. arg_occ | null args = UnkOcc
  943. | otherwise = evalScrutOcc
  944. ----------------------
  945. scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
  946. scTopBind env (Rec prs)
  947. | Just threshold <- sc_size env
  948. , not force_spec
  949. , not (all (couldBeSmallEnoughToInline threshold) rhss)
  950. -- No specialisation
  951. = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
  952. ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
  953. ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
  954. | otherwise -- Do specialisation
  955. = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
  956. rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
  957. ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
  958. ; let rhs_usg = combineUsages rhs_usgs
  959. ; (_, specs) <- specLoop (scForce rhs_env2 force_spec)
  960. (scu_calls rhs_usg) rhs_infos nullUsage
  961. [SI [] 0 Nothing | _ <- bndrs]
  962. ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
  963. Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
  964. where
  965. (bndrs,rhss) = unzip prs
  966. force_spec = any (forceSpecBndr env) bndrs
  967. -- Note [Forcing specialisation]
  968. scTopBind env (NonRec bndr rhs)
  969. = do { (_, rhs') <- scExpr env rhs
  970. ; let (env1, bndr') = extendBndr env bndr
  971. env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
  972. ; return (env2, NonRec bndr' rhs') }
  973. ----------------------
  974. scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
  975. scRecRhs env (bndr,rhs)
  976. = do { let (arg_bndrs,body) = collectBinders rhs
  977. (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
  978. ; (body_usg, body') <- scExpr body_env body
  979. ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
  980. ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
  981. arg_bndrs body arg_occs) }
  982. -- The arg_occs says how the visible,
  983. -- lambda-bound binders of the RHS are used
  984. -- (including the TyVar binders)
  985. -- Two pats are the same if they match both ways
  986. ----------------------
  987. specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
  988. specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
  989. = [(id,rhs) | OS _ _ id rhs <- specs] ++
  990. -- First the specialised bindings
  991. [(fn `addIdSpecialisations` rules, new_rhs)]
  992. -- And now the original binding
  993. where
  994. rules = [r | OS _ r _ _ <- specs]
  995. \end{code}
  996. %************************************************************************
  997. %* *
  998. The specialiser itself
  999. %* *
  1000. %************************************************************************
  1001. \begin{code}
  1002. data RhsInfo = RI OutId -- The binder
  1003. OutExpr -- The new RHS
  1004. [InVar] InExpr -- The *original* RHS (\xs.body)
  1005. -- Note [Specialise original body]
  1006. [ArgOcc] -- Info on how the xs occur in body
  1007. data SpecInfo = SI [OneSpec] -- The specialisations we have generated
  1008. Int -- Length of specs; used for numbering them
  1009. (Maybe ScUsage) -- Just cs => we have not yet used calls in the
  1010. -- from calls in the *original* RHS as
  1011. -- seeds for new specialisations;
  1012. -- if you decide to do so, here is the
  1013. -- RHS usage (which has not yet been
  1014. -- unleashed)
  1015. -- Nothing => we have
  1016. -- See Note [Local recursive groups]
  1017. -- One specialisation: Rule plus definition
  1018. data OneSpec = OS CallPat -- Call pattern that generated this specialisation
  1019. CoreRule -- Rule connecting original id with the specialisation
  1020. OutId OutExpr -- Spec id + its rhs
  1021. specLoop :: ScEnv
  1022. -> CallEnv
  1023. -> [RhsInfo]
  1024. -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
  1025. -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
  1026. specLoop env all_calls rhs_infos usg_so_far specs_so_far
  1027. = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
  1028. ; let (new_usg_s, all_specs) = unzip specs_w_usg
  1029. new_usg = combineUsages new_usg_s
  1030. new_calls = scu_calls new_usg
  1031. all_usg = usg_so_far `combineUsage` new_usg
  1032. ; if isEmptyVarEnv new_calls then
  1033. return (all_usg, all_specs)
  1034. else
  1035. specLoop env new_calls rhs_infos all_usg all_specs }
  1036. specialise
  1037. :: ScEnv
  1038. -> CallEnv -- Info on calls
  1039. -> RhsInfo
  1040. -> SpecInfo -- Original RHS plus patterns dealt with
  1041. -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
  1042. -- Note: this only generates *specialised* bindings
  1043. -- The original binding is added by specInfoBinds
  1044. --
  1045. -- Note: the rhs here is the optimised version of the original rhs
  1046. -- So when we make a specialised copy of the RHS, we're starting
  1047. -- from an RHS whose nested functions have been optimised already.
  1048. specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
  1049. spec_info@(SI specs spec_count mb_unspec)
  1050. | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
  1051. , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
  1052. , notNull arg_bndrs -- Only specialise functions
  1053. , Just all_calls <- lookupVarEnv bind_calls fn
  1054. = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
  1055. -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
  1056. -- , text "arg_occs" <+> ppr arg_occs
  1057. -- , text "calls" <+> ppr all_calls
  1058. -- , text "good pats" <+> ppr pats]) $
  1059. -- return ()
  1060. -- Bale out if too many specialisations
  1061. ; let n_pats = length pats
  1062. spec_count' = n_pats + spec_count
  1063. ; case sc_count env of
  1064. Just max | not (sc_force env) && spec_count' > max
  1065. -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for
  1066. then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125
  1067. return (nullUsage, spec_info)
  1068. else return (nullUsage, spec_info)
  1069. where
  1070. msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
  1071. , nest 2 (ptext (sLit "has") <+>
  1072. speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
  1073. ptext (sLit "but the limit is") <+> int max) ]
  1074. , ptext (sLit "Use -fspec-constr-count=n to set the bound")
  1075. , extra ]
  1076. extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
  1077. | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
  1078. _normal_case -> do {
  1079. let spec_env = decreaseSpecCount env n_pats
  1080. ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
  1081. (pats `zip` [spec_count..])
  1082. -- See Note [Specialise original body]
  1083. ; let spec_usg = combineUsages spec_usgs
  1084. (new_usg, mb_unspec')
  1085. = case mb_unspec of
  1086. Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
  1087. _ -> (spec_usg, mb_unspec)
  1088. ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
  1089. | otherwise
  1090. = return (nullUsage, spec_info) -- The boring case
  1091. ---------------------
  1092. spec_one :: ScEnv
  1093. -> OutId -- Function
  1094. -> [InVar] -- Lambda-binders of RHS; should match patterns
  1095. -> InExpr -- Body of the original function
  1096. -> (CallPat, Int)
  1097. -> UniqSM (ScUsage, OneSpec) -- Rule and binding
  1098. -- spec_one creates a specialised copy of the function, together
  1099. -- with a rule for using it. I'm very proud of how short this
  1100. -- function is, considering what it does :-).
  1101. {-
  1102. Example
  1103. In-scope: a, x::a
  1104. f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
  1105. [c::*, v::(b,c) are presumably bound by the (...) part]
  1106. ==>
  1107. f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
  1108. (...entire body of f...) [b -> (b,c),
  1109. y -> ((:) (a,(b,c)) (x,v) hw)]
  1110. RULE: forall b::* c::*, -- Note, *not* forall a, x
  1111. v::(b,c),
  1112. hw::[(a,(b,c))] .
  1113. f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
  1114. -}
  1115. spec_one env fn arg_bndrs body (call_pat@(qvars

Large files files are truncated, but you can click here to view the full file