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