compiler/specialise/SpecConstr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[SpecConstr]{Specialise over constructors}
   5
   6 \begin{code}
   7 -- The above warning supression flag is a temporary kludge.
   8 -- While working on this module you are encouraged to remove it and fix
   9 -- any warnings in the module. See
  10 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  11 -- for details
  12
  13 module SpecConstr(
  14         specConstrProgram
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import CoreSyn
  20 import CoreSubst
  21 import CoreUtils
  22 import CoreUnfold       ( couldBeSmallEnoughToInline )
  23 import CoreFVs          ( exprsFreeVars )
  24 import WwLib            ( mkWorkerArgs )
  25 import DataCon          ( dataConRepArity, dataConUnivTyVars )
  26 import Coercion
  27 import Rules
  28 import Type             hiding( substTy )
  29 import Id
  30 import MkId             ( mkImpossibleExpr )
  31 import Var
  32 import VarEnv
  33 import VarSet
  34 import Name
  35 import DynFlags         ( DynFlags(..) )
  36 import StaticFlags      ( opt_PprStyle_Debug )
  37 import StaticFlags      ( opt_SpecInlineJoinPoints )
  38 import BasicTypes       ( Activation(..) )
  39 import Maybes           ( orElse, catMaybes, isJust, isNothing )
  40 import Util
  41 import List             ( nubBy, partition )
  42 import UniqSupply
  43 import Outputable
  44 import FastString
  45 import UniqFM
  46 import MonadUtils
  47 import Control.Monad    ( zipWithM )
  48 \end{code}
  49
  50 -----------------------------------------------------
  51                         Game plan
  52 -----------------------------------------------------
  53
  54 Consider
  55         drop n []     = []
  56         drop 0 xs     = []
  57         drop n (x:xs) = drop (n-1) xs
  58
  59 After the first time round, we could pass n unboxed.  This happens in
  60 numerical code too.  Here's what it looks like in Core:
  61
  62         drop n xs = case xs of
  63                       []     -> []
  64                       (y:ys) -> case n of
  65                                   I# n# -> case n# of
  66                                              0 -> []
  67                                              _ -> drop (I# (n# -# 1#)) xs
  68
  69 Notice that the recursive call has an explicit constructor as argument.
  70 Noticing this, we can make a specialised version of drop
  71
  72         RULE: drop (I# n#) xs ==> drop' n# xs
  73
  74         drop' n# xs = let n = I# n# in ...orig RHS...
  75
  76 Now the simplifier will apply the specialisation in the rhs of drop', giving
  77
  78         drop' n# xs = case xs of
  79                       []     -> []
  80                       (y:ys) -> case n# of
  81                                   0 -> []
  82                                   _ -> drop (n# -# 1#) xs
  83
  84 Much better!
  85
  86 We'd also like to catch cases where a parameter is carried along unchanged,
  87 but evaluated each time round the loop:
  88
  89         f i n = if i>0 || i>n then i else f (i*2) n
  90
  91 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
  92 In Core, by the time we've w/wd (f is strict in i) we get
  93
  94         f i# n = case i# ># 0 of
  95                    False -> I# i#
  96                    True  -> case n of n' { I# n# ->
  97                             case i# ># n# of
  98                                 False -> I# i#
  99                                 True  -> f (i# *# 2#) n'
 100
 101 At the call to f, we see that the argument, n is know to be (I# n#),
 102 and n is evaluated elsewhere in the body of f, so we can play the same
 103 trick as above.
 104
 105
 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
 117 This happens if
 118   (a) the argument p is used in other than a case-scrutinsation way.
 119   (b) the argument to the call is not a 'fresh' tuple; you have to
 120         look into its unfolding to see that it's a tuple
 121
 122 Hence the "OR" part of Note [Good arguments] below.
 123
 124 ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves
 125 allocation, but does perhaps save evals. In the RULE we'd have
 126 something like
 127
 128   f (I# x#) = f' (I# x#) x#
 129
 130 If at the call site the (I# x) was an unfolding, then we'd have to
 131 rely on CSE to eliminate the duplicate allocation.... This alternative
 132 doesn't look attractive enough to pursue.
 133
 134 ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that
 135 the conservative reboxing story prevents many useful functions from being
 136 specialised.  Example:
 137         foo :: Maybe Int -> Int -> Int
 138         foo   (Just m) 0 = 0
 139         foo x@(Just m) n = foo x (n-m)
 140 Here the use of 'x' will clearly not require boxing in the specialised function.
 141
 142 The strictness analyser has the same problem, in fact.  Example:
 143         f p@(a,b) = ...
 144 If we pass just 'a' and 'b' to the worker, it might need to rebox the
 145 pair to create (a,b).  A more sophisticated analysis might figure out
 146 precisely the cases in which this could happen, but the strictness
 147 analyser does no such analysis; it just passes 'a' and 'b', and hopes
 148 for the best.
 149
 150 So my current choice is to make SpecConstr similarly aggressive, and
 151 ignore the bad potential of reboxing.
 152
 153
 154 Note [Good arguments]
 155 ~~~~~~~~~~~~~~~~~~~~~
 156 So we look for
 157
 158 * A self-recursive function.  Ignore mutual recursion for now,
 159   because it's less common, and the code is simpler for self-recursion.
 160
 161 * EITHER
 162
 163    a) At a recursive call, one or more parameters is an explicit
 164       constructor application
 165         AND
 166       That same parameter is scrutinised by a case somewhere in
 167       the RHS of the function
 168
 169   OR
 170
 171     b) At a recursive call, one or more parameters has an unfolding
 172        that is an explicit constructor application
 173         AND
 174       That same parameter is scrutinised by a case somewhere in
 175       the RHS of the function
 176         AND
 177       Those are the only uses of the parameter (see Note [Reboxing])
 178
 179
 180 What to abstract over
 181 ~~~~~~~~~~~~~~~~~~~~~
 182 There's a bit of a complication with type arguments.  If the call
 183 site looks like
 184
 185         f p = ...f ((:) [a] x xs)...
 186
 187 then our specialised function look like
 188
 189         f_spec x xs = let p = (:) [a] x xs in ....as before....
 190
 191 This only makes sense if either
 192   a) the type variable 'a' is in scope at the top of f, or
 193   b) the type variable 'a' is an argument to f (and hence fs)
 194
 195 Actually, (a) may hold for value arguments too, in which case
 196 we may not want to pass them.  Supose 'x' is in scope at f's
 197 defn, but xs is not.  Then we'd like
 198
 199         f_spec xs = let p = (:) [a] x xs in ....as before....
 200
 201 Similarly (b) may hold too.  If x is already an argument at the
 202 call, no need to pass it again.
 203
 204 Finally, if 'a' is not in scope at the call site, we could abstract
 205 it as we do the term variables:
 206
 207         f_spec a x xs = let p = (:) [a] x xs in ...as before...
 208
 209 So the grand plan is:
 210
 211         * abstract the call site to a constructor-only pattern
 212           e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)
 213
 214         * Find the free variables of the abstracted pattern
 215
 216         * Pass these variables, less any that are in scope at
 217           the fn defn.  But see Note [Shadowing] below.
 218
 219
 220 NOTICE that we only abstract over variables that are not in scope,
 221 so we're in no danger of shadowing variables used in "higher up"
 222 in f_spec's RHS.
 223
 224
 225 Note [Shadowing]
 226 ~~~~~~~~~~~~~~~~
 227 In this pass we gather up usage information that may mention variables
 228 that are bound between the usage site and the definition site; or (more
 229 seriously) may be bound to something different at the definition site.
 230 For example:
 231
 232         f x = letrec g y v = let x = ...
 233                              in ...(g (a,b) x)...
 234
 235 Since 'x' is in scope at the call site, we may make a rewrite rule that
 236 looks like
 237         RULE forall a,b. g (a,b) x = ...
 238 But this rule will never match, because it's really a different 'x' at
 239 the call site -- and that difference will be manifest by the time the
 240 simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*
 241 no-shadowing, so perhaps it may not be distinct?]
 242
 243 Anyway, the rule isn't actually wrong, it's just not useful.  One possibility
 244 is to run deShadowBinds before running SpecConstr, but instead we run the
 245 simplifier.  That gives the simplest possible program for SpecConstr to
 246 chew on; and it virtually guarantees no shadowing.
 247
 248 Note [Specialising for constant parameters]
 249 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 250 This one is about specialising on a *constant* (but not necessarily
 251 constructor) argument
 252
 253     foo :: Int -> (Int -> Int) -> Int
 254     foo 0 f = 0
 255     foo m f = foo (f m) (+1)
 256
 257 It produces
 258
 259     lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
 260     lvl_rmV =
 261       \ (ds_dlk :: GHC.Base.Int) ->
 262         case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
 263         GHC.Base.I# (GHC.Prim.+# x_alG 1)
 264
 265     T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
 266     GHC.Prim.Int#
 267     T.$wfoo =
 268       \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
 269         case ww_sme of ds_Xlw {
 270           __DEFAULT ->
 271         case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
 272         T.$wfoo ww1_Xmz lvl_rmV
 273         };
 274           0 -> 0
 275         }
 276
 277 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
 278 with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.
 279
 280 When is this worth it?  Call the constant 'lvl'
 281 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
 282   parameter is scrutinised anywhere in the body.
 283
 284 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
 285   parameter is applied (...to enough arguments...?)
 286
 287   Also do this is if the function has RULES?
 288
 289 Also
 290
 291 Note [Specialising for lambda parameters]
 292 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 293     foo :: Int -> (Int -> Int) -> Int
 294     foo 0 f = 0
 295     foo m f = foo (f m) (\n -> n-m)
 296
 297 This is subtly different from the previous one in that we get an
 298 explicit lambda as the argument:
 299
 300     T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
 301     GHC.Prim.Int#
 302     T.$wfoo =
 303       \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
 304         case ww_sm8 of ds_Xlr {
 305           __DEFAULT ->
 306         case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
 307         T.$wfoo
 308           ww1_Xmq
 309           (\ (n_ad3 :: GHC.Base.Int) ->
 310              case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
 311              GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
 312              })
 313         };
 314           0 -> 0
 315         }
 316
 317 I wonder if SpecConstr couldn't be extended to handle this? After all,
 318 lambda is a sort of constructor for functions and perhaps it already
 319 has most of the necessary machinery?
 320
 321 Furthermore, there's an immediate win, because you don't need to allocate the lamda
 322 at the call site; and if perchance it's called in the recursive call, then you
 323 may avoid allocating it altogether.  Just like for constructors.
 324
 325 Looks cool, but probably rare...but it might be easy to implement.
 326
 327
 328 Note [SpecConstr for casts]
 329 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 330 Consider
 331     data family T a :: *
 332     data instance T Int = T Int
 333
 334     foo n = ...
 335        where
 336          go (T 0) = 0
 337          go (T n) = go (T (n-1))
 338
 339 The recursive call ends up looking like
 340         go (T (I# ...) `cast` g)
 341 So we want to spot the construtor application inside the cast.
 342 That's why we have the Cast case in argToPat
 343
 344 Note [Local recursive groups]
 345 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 346 For a *local* recursive group, we can see all the calls to the
 347 function, so we seed the specialisation loop from the calls in the
 348 body, not from the calls in the RHS.  Consider:
 349
 350   bar m n = foo n (n,n) (n,n) (n,n) (n,n)
 351    where
 352      foo n p q r s
 353        | n == 0    = m
 354        | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
 355        | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
 356        | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
 357        | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
 358
 359 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
 360 most of which are not needed.  But if we start with the (single) call
 361 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
 362 the recursive calls go to this fully-specialised copy. Indeed, the original
 363 function is later collected as dead code.  This is very important in
 364 specialising the loops arising from stream fusion, for example in NDP where
 365 we were getting literally hundreds of (mostly unused) specialisations of
 366 a local function.
 367
 368 Note [Do not specialise diverging functions]
 369 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 370 Specialising a function that just diverges is a waste of code.
 371 Furthermore, it broke GHC (simpl014) thus:
 372    {-# STR Sb #-}
 373    f = \x. case x of (a,b) -> f x
 374 If we specialise f we get
 375    f = \x. case x of (a,b) -> fspec a b
 376 But fspec doesn't have decent strictnes info.  As it happened,
 377 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
 378 and hence f.  But now f's strictness is less than its arity, which
 379 breaks an invariant.
 380
 381 -----------------------------------------------------
 382                 Stuff not yet handled
 383 -----------------------------------------------------
 384
 385 Here are notes arising from Roman's work that I don't want to lose.
 386
 387 Example 1
 388 ~~~~~~~~~
 389     data T a = T !a
 390
 391     foo :: Int -> T Int -> Int
 392     foo 0 t = 0
 393     foo x t | even x    = case t of { T n -> foo (x-n) t }
 394             | otherwise = foo (x-1) t
 395
 396 SpecConstr does no specialisation, because the second recursive call
 397 looks like a boxed use of the argument.  A pity.
 398
 399     $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
 400     $wfoo_sFw =
 401       \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
 402          case ww_sFo of ds_Xw6 [Just L] {
 403            __DEFAULT ->
 404                 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
 405                   __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
 406                   0 ->
 407                     case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
 408                     case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
 409                     $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
 410                     } } };
 411            0 -> 0
 412
 413 Example 2
 414 ~~~~~~~~~
 415     data a :*: b = !a :*: !b
 416     data T a = T !a
 417
 418     foo :: (Int :*: T Int) -> Int
 419     foo (0 :*: t) = 0
 420     foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }
 421                   | otherwise = foo ((x-1) :*: t)
 422
 423 Very similar to the previous one, except that the parameters are now in
 424 a strict tuple. Before SpecConstr, we have
 425
 426     $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
 427     $wfoo_sG3 =
 428       \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
 429     GHC.Base.Int) ->
 430         case ww_sFU of ds_Xws [Just L] {
 431           __DEFAULT ->
 432         case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
 433           __DEFAULT ->
 434             case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
 435             $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1
 436             };
 437           0 ->
 438             case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
 439             case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
 440             $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2
 441             } } };
 442           0 -> 0 }
 443
 444 We get two specialisations:
 445 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
 446                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
 447                   = Foo.$s$wfoo1 a_sFB sc_sGC ;
 448 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
 449                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
 450                   = Foo.$s$wfoo y_aFp sc_sGC ;
 451
 452 But perhaps the first one isn't good.  After all, we know that tpl_B2 is
 453 a T (I# x) really, because T is strict and Int has one constructor.  (We can't
 454 unbox the strict fields, becuase T is polymorphic!)
 455
 456
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection{Top level wrapper stuff}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 \begin{code}
 465 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]
 466 specConstrProgram dflags us binds = fst $ initUs us (go (initScEnv dflags) binds)
 467   where
 468     go _   []           = return []
 469     go env (bind:binds) = do (env', bind') <- scTopBind env bind
 470                              binds' <- go env' binds
 471                              return (bind' : binds')
 472 \end{code}
 473
 474
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsection{Environment: goes downwards}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 \begin{code}
 482 data ScEnv = SCE { sc_size  :: Maybe Int,       -- Size threshold
 483                    sc_count :: Maybe Int,       -- Max # of specialisations for any one fn
 484
 485                    sc_subst :: Subst,           -- Current substitution
 486                                                 -- Maps InIds to OutExprs
 487
 488                    sc_how_bound :: HowBoundEnv,
 489                         -- Binds interesting non-top-level variables
 490                         -- Domain is OutVars (*after* applying the substitution)
 491
 492                    sc_vals  :: ValueEnv
 493                         -- Domain is OutIds (*after* applying the substitution)
 494                         -- Used even for top-level bindings (but not imported ones)
 495              }
 496
 497 ---------------------
 498 -- As we go, we apply a substitution (sc_subst) to the current term
 499 type InExpr = CoreExpr          -- _Before_ applying the subst
 500
 501 type OutExpr = CoreExpr         -- _After_ applying the subst
 502 type OutId   = Id
 503 type OutVar  = Var
 504
 505 ---------------------
 506 type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars
 507
 508 ---------------------
 509 type ValueEnv = IdEnv Value             -- Domain is OutIds
 510 data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors
 511               | LambdaVal               -- Inlinable lambdas or PAPs
 512
 513 instance Outputable Value where
 514    ppr (ConVal con args) = ppr con <+> interpp'SP args
 515    ppr LambdaVal         = ptext (sLit "<Lambda>")
 516
 517 ---------------------
 518 initScEnv :: DynFlags -> ScEnv
 519 initScEnv dflags
 520   = SCE { sc_size = specConstrThreshold dflags,
 521           sc_count = specConstrCount dflags,
 522           sc_subst = emptySubst,
 523           sc_how_bound = emptyVarEnv,
 524           sc_vals = emptyVarEnv }
 525
 526 data HowBound = RecFun  -- These are the recursive functions for which
 527                         -- we seek interesting call patterns
 528
 529               | RecArg  -- These are those functions' arguments, or their sub-components;
 530                         -- we gather occurrence information for these
 531
 532 instance Outputable HowBound where
 533   ppr RecFun = text "RecFun"
 534   ppr RecArg = text "RecArg"
 535
 536 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
 537 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
 538
 539 scSubstId :: ScEnv -> Id -> CoreExpr
 540 scSubstId env v = lookupIdSubst (sc_subst env) v
 541
 542 scSubstTy :: ScEnv -> Type -> Type
 543 scSubstTy env ty = substTy (sc_subst env) ty
 544
 545 zapScSubst :: ScEnv -> ScEnv
 546 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
 547
 548 extendScInScope :: ScEnv -> [Var] -> ScEnv
 549         -- Bring the quantified variables into scope
 550 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
 551
 552         -- Extend the substitution
 553 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
 554 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
 555
 556 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
 557 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
 558
 559 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
 560 extendHowBound env bndrs how_bound
 561   = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
 562                             [(bndr,how_bound) | bndr <- bndrs] }
 563
 564 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
 565 extendBndrsWith how_bound env bndrs
 566   = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
 567   where
 568     (subst', bndrs') = substBndrs (sc_subst env) bndrs
 569     hb_env' = sc_how_bound env `extendVarEnvList`
 570                     [(bndr,how_bound) | bndr <- bndrs']
 571
 572 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
 573 extendBndrWith how_bound env bndr
 574   = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
 575   where
 576     (subst', bndr') = substBndr (sc_subst env) bndr
 577     hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
 578
 579 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
 580 extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')
 581                       where
 582                         (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
 583
 584 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
 585 extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')
 586                       where
 587                         (subst', bndr') = substBndr (sc_subst env) bndr
 588
 589 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
 590 extendValEnv env _  Nothing   = env
 591 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
 592
 593 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
 594 -- When we encounter
 595 --      case scrut of b
 596 --          C x y -> ...
 597 -- we want to bind b, to (C x y)
 598 -- NB1: Extends only the sc_vals part of the envt
 599 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
 600 --      they are potentially made alive by the [b -> C x y] binding
 601 extendCaseBndrs env case_bndr con alt_bndrs
 602   | isDeadBinder case_bndr
 603   = (env, alt_bndrs)
 604   | otherwise
 605   = (env1, map zap alt_bndrs)
 606         -- NB: We used to bind v too, if scrut = (Var v); but
 607         --     the simplifer has already done this so it seems
 608         --     redundant to do so here
 609         -- case scrut of
 610         --      Var v  -> extendValEnv env1 v cval
 611         --      _other -> env1
 612  where
 613    zap v | isTyVar v = v                -- See NB2 above
 614          | otherwise = zapIdOccInfo v
 615    env1 = extendValEnv env case_bndr cval
 616    cval = case con of
 617                 DEFAULT    -> Nothing
 618                 LitAlt {}  -> Just (ConVal con [])
 619                 DataAlt {} -> Just (ConVal con vanilla_args)
 620                       where
 621                         vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
 622                                        varsToCoreExprs alt_bndrs
 623 \end{code}
 624
 625
 626 %************************************************************************
 627 %*                                                                      *
 628 \subsection{Usage information: flows upwards}
 629 %*                                                                      *
 630 %************************************************************************
 631
 632 \begin{code}
 633 data ScUsage
 634    = SCU {
 635         scu_calls :: CallEnv,           -- Calls
 636                                         -- The functions are a subset of the
 637                                         --      RecFuns in the ScEnv
 638
 639         scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences
 640      }                                  -- The domain is OutIds
 641
 642 type CallEnv = IdEnv [Call]
 643 type Call = (ValueEnv, [CoreArg])
 644         -- The arguments of the call, together with the
 645         -- env giving the constructor bindings at the call site
 646
 647 nullUsage :: ScUsage
 648 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
 649
 650 combineCalls :: CallEnv -> CallEnv -> CallEnv
 651 combineCalls = plusVarEnv_C (++)
 652
 653 combineUsage :: ScUsage -> ScUsage -> ScUsage
 654 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
 655                            scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
 656
 657 combineUsages :: [ScUsage] -> ScUsage
 658 combineUsages [] = nullUsage
 659 combineUsages us = foldr1 combineUsage us
 660
 661 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
 662 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
 663   = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
 664      lookupVarEnv sc_occs bndr `orElse` NoOcc)
 665
 666 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
 667 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
 668   = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
 669      [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
 670
 671 data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument
 672             | UnkOcc    -- Used in some unknown way
 673
 674             | ScrutOcc (UniqFM [ArgOcc])        -- See Note [ScrutOcc]
 675
 676             | BothOcc   -- Definitely taken apart, *and* perhaps used in some other way
 677
 678 {-      Note  [ScrutOcc]
 679
 680 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
 681 is *only* taken apart or applied.
 682
 683   Functions, literal: ScrutOcc emptyUFM
 684   Data constructors:  ScrutOcc subs,
 685
 686 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
 687 The domain of the UniqFM is the Unique of the data constructor
 688
 689 The [ArgOcc] is the occurrences of the *pattern-bound* components
 690 of the data structure.  E.g.
 691         data T a = forall b. MkT a b (b->a)
 692 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
 693
 694 -}
 695
 696 instance Outputable ArgOcc where
 697   ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
 698   ppr UnkOcc        = ptext (sLit "unk-occ")
 699   ppr BothOcc       = ptext (sLit "both-occ")
 700   ppr NoOcc         = ptext (sLit "no-occ")
 701
 702 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
 703 -- that if the thing is scrutinised anywhere then we get to see that
 704 -- in the overall result, even if it's also used in a boxed way
 705 -- This might be too agressive; see Note [Reboxing] Alternative 3
 706 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
 707 combineOcc NoOcc         occ           = occ
 708 combineOcc occ           NoOcc         = occ
 709 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
 710 combineOcc _occ          (ScrutOcc ys) = ScrutOcc ys
 711 combineOcc (ScrutOcc xs) _occ          = ScrutOcc xs
 712 combineOcc UnkOcc        UnkOcc        = UnkOcc
 713 combineOcc _        _                  = BothOcc
 714
 715 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
 716 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
 717
 718 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
 719 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
 720 -- is a variable, and an interesting variable
 721 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
 722 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
 723 setScrutOcc env usg (Var v)    occ
 724   | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
 725   | otherwise                           = usg
 726 setScrutOcc _env usg _other _occ        -- Catch-all
 727   = usg
 728
 729 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
 730 -- Find usage of components of data con; returns [UnkOcc...] if unknown
 731 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
 732
 733 conArgOccs (ScrutOcc fm) (DataAlt dc)
 734   | Just pat_arg_occs <- lookupUFM fm dc
 735   = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
 736
 737 conArgOccs _other _con = repeat UnkOcc
 738 \end{code}
 739
 740 %************************************************************************
 741 %*                                                                      *
 742 \subsection{The main recursive function}
 743 %*                                                                      *
 744 %************************************************************************
 745
 746 The main recursive function gathers up usage information, and
 747 creates specialised versions of functions.
 748
 749 \begin{code}
 750 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
 751         -- The unique supply is needed when we invent
 752         -- a new name for the specialised function and its args
 753
 754 scExpr env e = scExpr' env e
 755
 756
 757 scExpr' env (Var v)     = case scSubstId env v of
 758                             Var v' -> return (varUsage env v' UnkOcc, Var v')
 759                             e'     -> scExpr (zapScSubst env) e'
 760
 761 scExpr' env (Type t)    = return (nullUsage, Type (scSubstTy env t))
 762 scExpr' _   e@(Lit {})  = return (nullUsage, e)
 763 scExpr' env (Note n e)  = do (usg,e') <- scExpr env e
 764                              return (usg, Note n e')
 765 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
 766                              return (usg, Cast e' (scSubstTy env co))
 767 scExpr' env e@(App _ _) = scApp env (collectArgs e)
 768 scExpr' env (Lam b e)   = do let (env', b') = extendBndr env b
 769                              (usg, e') <- scExpr env' e
 770                              return (usg, Lam b' e')
 771
 772 scExpr' env (Case scrut b ty alts)
 773   = do  { (scrut_usg, scrut') <- scExpr env scrut
 774         ; case isValue (sc_vals env) scrut' of
 775                 Just (ConVal con args) -> sc_con_app con args scrut'
 776                 _other                 -> sc_vanilla scrut_usg scrut'
 777         }
 778   where
 779     sc_con_app con args scrut'  -- Known constructor; simplify
 780         = do { let (_, bs, rhs) = findAlt con alts
 781                                   `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
 782                    alt_env'  = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
 783              ; scExpr alt_env' rhs }
 784
 785     sc_vanilla scrut_usg scrut' -- Normal case
 786      = do { let (alt_env,b') = extendBndrWith RecArg env b
 787                         -- Record RecArg for the components
 788
 789           ; (alt_usgs, alt_occs, alts')
 790                 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
 791
 792           ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
 793                 scrut_occ        = foldr combineOcc b_occ alt_occs
 794                 scrut_usg'       = setScrutOcc env scrut_usg scrut' scrut_occ
 795                 -- The combined usage of the scrutinee is given
 796                 -- by scrut_occ, which is passed to scScrut, which
 797                 -- in turn treats a bare-variable scrutinee specially
 798
 799           ; return (alt_usg `combineUsage` scrut_usg',
 800                     Case scrut' b' (scSubstTy env ty) alts') }
 801
 802     sc_alt env _scrut' b' (con,bs,rhs)
 803       = do { let (env1, bs1)  = extendBndrsWith RecArg env bs
 804                  (env2, bs2) = extendCaseBndrs env1 b' con bs1
 805            ; (usg,rhs') <- scExpr env2 rhs
 806            ; let (usg', arg_occs) = lookupOccs usg bs2
 807                  scrut_occ = case con of
 808                                 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
 809                                 _          -> ScrutOcc emptyUFM
 810            ; return (usg', scrut_occ, (con, bs2, rhs')) }
 811
 812 scExpr' env (Let (NonRec bndr rhs) body)
 813   | isTyVar bndr        -- Type-lets may be created by doBeta
 814   = scExpr' (extendScSubst env bndr rhs) body
 815   | otherwise
 816   = do  { let (body_env, bndr') = extendBndr env bndr
 817         ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
 818         ; let rhs' = mkLams args' rhs_body'
 819
 820         ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
 821             do  {       -- Vanilla case
 822                   let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
 823                         -- Record if the RHS is a value
 824                 ; (body_usg, body') <- scExpr body_env2 body
 825                 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
 826           else  -- For now, just brutally inline the join point
 827             do { let body_env2 = extendScSubst env bndr rhs'
 828                ; scExpr body_env2 body } }
 829
 830
 831 {-  Old code
 832             do  {       -- Join-point case
 833                   let body_env2 = extendHowBound body_env [bndr'] RecFun
 834                         -- If the RHS of this 'let' contains calls
 835                         -- to recursive functions that we're trying
 836                         -- to specialise, then treat this let too
 837                         -- as one to specialise
 838                 ; (body_usg, body') <- scExpr body_env2 body
 839
 840                 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
 841
 842                 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
 843                           `combineUsage` rhs_usg `combineUsage` spec_usg,
 844                           mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
 845         }
 846 -}
 847
 848 -- A *local* recursive group: see Note [Local recursive groups]
 849 scExpr' env (Let (Rec prs) body)
 850   = do  { let (bndrs,rhss) = unzip prs
 851               (rhs_env1,bndrs') = extendRecBndrs env bndrs
 852               rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
 853
 854         ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
 855         ; (body_usg, body')     <- scExpr rhs_env2 body
 856
 857         -- NB: start specLoop from body_usg
 858         ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage
 859                                         [SI [] 0 (Just usg) | usg <- rhs_usgs]
 860
 861         ; let all_usg = spec_usg `combineUsage` body_usg
 862               bind'   = Rec (concat (zipWith specInfoBinds rhs_infos specs))
 863
 864         ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
 865                   Let bind' body') }
 866
 867 -----------------------------------
 868 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
 869
 870 scApp env (Var fn, args)        -- Function is a variable
 871   = ASSERT( not (null args) )
 872     do  { args_w_usgs <- mapM (scExpr env) args
 873         ; let (arg_usgs, args') = unzip args_w_usgs
 874               arg_usg = combineUsages arg_usgs
 875         ; case scSubstId env fn of
 876             fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
 877                         -- Do beta-reduction and try again
 878
 879             Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
 880                 where
 881                   fn_usg = case lookupHowBound env fn' of
 882                                 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
 883                                                      scu_occs  = emptyVarEnv }
 884                                 Just RecArg -> SCU { scu_calls = emptyVarEnv,
 885                                                      scu_occs  = unitVarEnv fn' (ScrutOcc emptyUFM) }
 886                                 Nothing     -> nullUsage
 887
 888
 889             other_fn' -> return (arg_usg, mkApps other_fn' args') }
 890                 -- NB: doing this ignores any usage info from the substituted
 891                 --     function, but I don't think that matters.  If it does
 892                 --     we can fix it.
 893   where
 894     doBeta :: OutExpr -> [OutExpr] -> OutExpr
 895     -- ToDo: adjust for System IF
 896     doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
 897     doBeta fn              args         = mkApps fn args
 898
 899 -- The function is almost always a variable, but not always.
 900 -- In particular, if this pass follows float-in,
 901 -- which it may, we can get
 902 --      (let f = ...f... in f) arg1 arg2
 903 scApp env (other_fn, args)
 904   = do  { (fn_usg,   fn')   <- scExpr env other_fn
 905         ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
 906         ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
 907
 908 ----------------------
 909 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
 910 scTopBind env (Rec prs)
 911   | Just threshold <- sc_size env
 912   , not (all (couldBeSmallEnoughToInline threshold) rhss)
 913                 -- No specialisation
 914   = do  { let (rhs_env,bndrs') = extendRecBndrs env bndrs
 915         ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
 916         ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
 917   | otherwise   -- Do specialisation
 918   = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
 919               rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
 920
 921         ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
 922         ; let rhs_usg = combineUsages rhs_usgs
 923
 924         ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage
 925                                  [SI [] 0 Nothing | _ <- bndrs]
 926
 927         ; return (rhs_env1,  -- For the body of the letrec, delete the RecFun business
 928                   Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
 929   where
 930     (bndrs,rhss) = unzip prs
 931
 932 scTopBind env (NonRec bndr rhs)
 933   = do  { (_, rhs') <- scExpr env rhs
 934         ; let (env1, bndr') = extendBndr env bndr
 935               env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
 936         ; return (env2, NonRec bndr' rhs') }
 937
 938 ----------------------
 939 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
 940 scRecRhs env (bndr,rhs)
 941   = do  { let (arg_bndrs,body) = collectBinders rhs
 942               (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
 943         ; (body_usg, body') <- scExpr body_env body
 944         ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
 945         ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
 946
 947                 -- The arg_occs says how the visible,
 948                 -- lambda-bound binders of the RHS are used
 949                 -- (including the TyVar binders)
 950                 -- Two pats are the same if they match both ways
 951
 952 ----------------------
 953 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
 954 specInfoBinds (fn, args, body, _) (SI specs _ _)
 955   = [(id,rhs) | OS _ _ id rhs <- specs] ++
 956     [(fn `addIdSpecialisations` rules, mkLams args body)]
 957   where
 958     rules = [r | OS _ r _ _ <- specs]
 959
 960 ----------------------
 961 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
 962 varUsage env v use
 963   | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
 964                                               , scu_occs = unitVarEnv v use }
 965   | otherwise                           = nullUsage
 966 \end{code}
 967
 968
 969 %************************************************************************
 970 %*                                                                      *
 971                 The specialiser itself
 972 %*                                                                      *
 973 %************************************************************************
 974
 975 \begin{code}
 976 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
 977         -- Info about the *original* RHS of a binding we are specialising
 978         -- Original binding f = \xs.body
 979         -- Plus info about usage of arguments
 980
 981 data SpecInfo = SI [OneSpec]            -- The specialisations we have generated
 982                    Int                  -- Length of specs; used for numbering them
 983                    (Maybe ScUsage)      -- Nothing => we have generated specialisations
 984                                         --            from calls in the *original* RHS
 985                                         -- Just cs => we haven't, and this is the usage
 986                                         --            of the original RHS
 987
 988         -- One specialisation: Rule plus definition
 989 data OneSpec  = OS CallPat              -- Call pattern that generated this specialisation
 990                    CoreRule             -- Rule connecting original id with the specialisation
 991                    OutId OutExpr        -- Spec id + its rhs
 992
 993
 994 specLoop :: ScEnv
 995          -> CallEnv
 996          -> [RhsInfo]
 997          -> ScUsage -> [SpecInfo]               -- One per binder; acccumulating parameter
 998          -> UniqSM (ScUsage, [SpecInfo])        -- ...ditto...
 999 specLoop env all_calls rhs_infos usg_so_far specs_so_far
1000   = do  { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
1001         ; let (new_usg_s, all_specs) = unzip specs_w_usg
1002               new_usg   = combineUsages new_usg_s
1003               new_calls = scu_calls new_usg
1004               all_usg   = usg_so_far `combineUsage` new_usg
1005         ; if isEmptyVarEnv new_calls then
1006                 return (all_usg, all_specs)
1007           else
1008                 specLoop env new_calls rhs_infos all_usg all_specs }
1009
1010 specialise
1011    :: ScEnv
1012    -> CallEnv                           -- Info on calls
1013    -> RhsInfo
1014    -> SpecInfo                          -- Original RHS plus patterns dealt with
1015    -> UniqSM (ScUsage, SpecInfo)        -- New specialised versions and their usage
1016
1017 -- Note: the rhs here is the optimised version of the original rhs
1018 -- So when we make a specialised copy of the RHS, we're starting
1019 -- from an RHS whose nested functions have been optimised already.
1020
1021 specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
1022                           spec_info@(SI specs spec_count mb_unspec)
1023   | not (isBottomingId fn)      -- Note [Do not specialise diverging functions]
1024   , notNull arg_bndrs           -- Only specialise functions
1025   , Just all_calls <- lookupVarEnv bind_calls fn
1026   = do  { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1027 --      ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
1028 --                                      text "calls" <+> ppr all_calls,
1029 --                                      text "good pats" <+> ppr pats])  $
1030 --        return ()
1031
1032                 -- Bale out if too many specialisations
1033                 -- Rather a hacky way to do so, but it'll do for now
1034         ; let spec_count' = length pats + spec_count
1035         ; case sc_count env of
1036             Just max | spec_count' > max
1037                 -> WARN( True, msg ) return (nullUsage, spec_info)
1038                 where
1039                    msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
1040                                     , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
1041                               , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1042                               , extra ]
1043                    extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1044                          | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1045
1046             _normal_case -> do {
1047
1048           (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1049                                                  (pats `zip` [spec_count..])
1050
1051         ; let spec_usg = combineUsages spec_usgs
1052               (new_usg, mb_unspec')
1053                   = case mb_unspec of
1054                       Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1055                       _                          -> (spec_usg,                      mb_unspec)
1056
1057         ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1058   | otherwise
1059   = return (nullUsage, spec_info)               -- The boring case
1060
1061
1062 ---------------------
1063 spec_one :: ScEnv
1064          -> OutId       -- Function
1065          -> [Var]       -- Lambda-binders of RHS; should match patterns
1066          -> CoreExpr    -- Body of the original function
1067          -> (CallPat, Int)
1068          -> UniqSM (ScUsage, OneSpec)   -- Rule and binding
1069
1070 -- spec_one creates a specialised copy of the function, together
1071 -- with a rule for using it.  I'm very proud of how short this
1072 -- function is, considering what it does :-).
1073
1074 {-
1075   Example
1076
1077      In-scope: a, x::a
1078      f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1079           [c::*, v::(b,c) are presumably bound by the (...) part]
1080   ==>
1081      f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1082                   (...entire body of f...) [b -> (b,c),
1083                                             y -> ((:) (a,(b,c)) (x,v) hw)]
1084
1085      RULE:  forall b::* c::*,           -- Note, *not* forall a, x
1086                    v::(b,c),
1087                    hw::[(a,(b,c))] .
1088
1089             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1090 -}
1091
1092 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1093   = do  {       -- Specialise the body
1094           let spec_env = extendScSubstList (extendScInScope env qvars)
1095                                            (arg_bndrs `zip` pats)
1096         ; (spec_usg, spec_body) <- scExpr spec_env body
1097
1098 --      ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1099 --                      text "calls" <+> (ppr (scu_calls spec_usg))])
1100 --        (return ())
1101
1102                 -- And build the results
1103         ; spec_uniq <- getUniqueUs
1104         ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1105                 -- Usual w/w hack to avoid generating
1106                 -- a spec_rhs of unlifted type and no args
1107
1108               fn_name   = idName fn
1109               fn_loc    = nameSrcSpan fn_name
1110               spec_occ  = mkSpecOcc (nameOccName fn_name)
1111               rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1112               spec_rhs  = mkLams spec_lam_args spec_body
1113               spec_id   = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1114               body_ty   = exprType spec_body
1115               rule_rhs  = mkVarApps (Var spec_id) spec_call_args
1116               rule      = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1117         ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1118
1119 -- In which phase should the specialise-constructor rules be active?
1120 -- Originally I made them always-active, but Manuel found that
1121 -- this defeated some clever user-written rules.  So Plan B
1122 -- is to make them active only in Phase 0; after all, currently,
1123 -- the specConstr transformation is only run after the simplifier
1124 -- has reached Phase 0.  In general one would want it to be
1125 -- flag-controllable, but for now I'm leaving it baked in
1126 --                                      [SLPJ Oct 01]
1127 specConstrActivation :: Activation
1128 specConstrActivation = ActiveAfter 0    -- Baked in; see comments above
1129 \end{code}
1130
1131 %************************************************************************
1132 %*                                                                      *
1133 \subsection{Argument analysis}
1134 %*                                                                      *
1135 %************************************************************************
1136
1137 This code deals with analysing call-site arguments to see whether
1138 they are constructor applications.
1139
1140
1141 \begin{code}
1142 type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments
1143
1144
1145 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1146         -- Result has no duplicate patterns,
1147         -- nor ones mentioned in done_pats
1148         -- Bool indicates that there was at least one boring pattern
1149 callsToPats env done_specs bndr_occs calls
1150   = do  { mb_pats <- mapM (callToPats env bndr_occs) calls
1151
1152         ; let good_pats :: [([Var], [CoreArg])]
1153               good_pats = catMaybes mb_pats
1154               done_pats = [p | OS p _ _ _ <- done_specs]
1155               is_done p = any (samePat p) done_pats
1156
1157         ; return (any isNothing mb_pats,
1158                   filterOut is_done (nubBy samePat good_pats)) }
1159
1160 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1161         -- The [Var] is the variables to quantify over in the rule
1162         --      Type variables come first, since they may scope
1163         --      over the following term variables
1164         -- The [CoreExpr] are the argument patterns for the rule
1165 callToPats env bndr_occs (con_env, args)
1166   | length args < length bndr_occs      -- Check saturated
1167   = return Nothing
1168   | otherwise
1169   = do  { let in_scope = substInScope (sc_subst env)
1170         ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1171         ; let (interesting_s, pats) = unzip prs
1172               pat_fvs = varSetElems (exprsFreeVars pats)
1173               qvars   = filterOut (`elemInScopeSet` in_scope) pat_fvs
1174                 -- Quantify over variables that are not in sccpe
1175                 -- at the call site
1176                 -- See Note [Shadowing] at the top
1177
1178               (tvs, ids) = partition isTyVar qvars
1179               qvars'     = tvs ++ ids
1180                 -- Put the type variables first; the type of a term
1181                 -- variable may mention a type variable
1182
1183         ; -- pprTrace "callToPats"  (ppr args $$ ppr prs $$ ppr bndr_occs) $
1184           if or interesting_s
1185           then return (Just (qvars', pats))
1186           else return Nothing }
1187
1188     -- argToPat takes an actual argument, and returns an abstracted
1189     -- version, consisting of just the "constructor skeleton" of the
1190     -- argument, with non-constructor sub-expression replaced by new
1191     -- placeholder variables.  For example:
1192     --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
1193
1194 argToPat :: InScopeSet                  -- What's in scope at the fn defn site
1195          -> ValueEnv                    -- ValueEnv at the call site
1196          -> CoreArg                     -- A call arg (or component thereof)
1197          -> ArgOcc
1198          -> UniqSM (Bool, CoreArg)
1199 -- Returns (interesting, pat),
1200 -- where pat is the pattern derived from the argument
1201 --            intersting=True if the pattern is non-trivial (not a variable or type)
1202 -- E.g.         x:xs         --> (True, x:xs)
1203 --              f xs         --> (False, w)        where w is a fresh wildcard
1204 --              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
1205 --              \x. x+y      --> (True, \x. x+y)
1206 --              lvl7         --> (True, lvl7)      if lvl7 is bound
1207 --                                                 somewhere further out
1208
1209 argToPat _in_scope _val_env arg@(Type {}) _arg_occ
1210   = return (False, arg)
1211
1212 argToPat in_scope val_env (Note _ arg) arg_occ
1213   = argToPat in_scope val_env arg arg_occ
1214         -- Note [Notes in call patterns]
1215         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1216         -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
1217         -- Perhaps we should not ignore profiling notes, but I'm going to
1218         -- ride roughshod over them all for now.
1219         --- See Note [Notes in RULE matching] in Rules
1220
1221 argToPat in_scope val_env (Let _ arg) arg_occ
1222   = argToPat in_scope val_env arg arg_occ
1223         -- Look through let expressions
1224         -- e.g.         f (let v = rhs in \y -> ...v...)
1225         -- Here we can specialise for f (\y -> ...)
1226         -- because the rule-matcher will look through the let.
1227
1228 argToPat in_scope val_env (Cast arg co) arg_occ
1229   = do  { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1230         ; let (ty1,ty2) = coercionKind co
1231         ; if not interesting then
1232                 wildCardPat ty2
1233           else do
1234         { -- Make a wild-card pattern for the coercion
1235           uniq <- getUniqueUs
1236         ; let co_name = mkSysTvName uniq (fsLit "sg")
1237               co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1238         ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1239
1240 {-      Disabling lambda specialisation for now
1241         It's fragile, and the spec_loop can be infinite
1242 argToPat in_scope val_env arg arg_occ
1243   | is_value_lam arg
1244   = return (True, arg)
1245   where
1246     is_value_lam (Lam v e)      -- Spot a value lambda, even if
1247         | isId v = True         -- it is inside a type lambda
1248         | otherwise = is_value_lam e
1249     is_value_lam other = False
1250 -}
1251
1252   -- Check for a constructor application
1253   -- NB: this *precedes* the Var case, so that we catch nullary constrs
1254 argToPat in_scope val_env arg arg_occ
1255   | Just (ConVal dc args) <- isValue val_env arg
1256   , case arg_occ of
1257         ScrutOcc _ -> True              -- Used only by case scrutinee
1258         BothOcc    -> case arg of       -- Used elsewhere
1259                         App {} -> True  --     see Note [Reboxing]
1260                         _other -> False
1261         _other     -> False     -- No point; the arg is not decomposed
1262   = do  { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1263         ; return (True, mk_con_app dc (map snd args')) }
1264
1265   -- Check if the argument is a variable that
1266   -- is in scope at the function definition site
1267   -- It's worth specialising on this if
1268   --    (a) it's used in an interesting way in the body
1269   --    (b) we know what its value is
1270 argToPat in_scope val_env (Var v) arg_occ
1271   | case arg_occ of { UnkOcc -> False; _other -> True },        -- (a)
1272     is_value                                                    -- (b)
1273   = return (True, Var v)
1274   where
1275     is_value
1276         | isLocalId v = v `elemInScopeSet` in_scope
1277                         && isJust (lookupVarEnv val_env v)
1278                 -- Local variables have values in val_env
1279         | otherwise   = isValueUnfolding (idUnfolding v)
1280                 -- Imports have unfoldings
1281
1282 --      I'm really not sure what this comment means
1283 --      And by not wild-carding we tend to get forall'd
1284 --      variables that are in soope, which in turn can
1285 --      expose the weakness in let-matching
1286 --      See Note [Matching lets] in Rules
1287
1288   -- Check for a variable bound inside the function.
1289   -- Don't make a wild-card, because we may usefully share
1290   --    e.g.  f a = let x = ... in f (x,x)
1291   -- NB: this case follows the lambda and con-app cases!!
1292 -- argToPat _in_scope _val_env (Var v) _arg_occ
1293 --   = return (False, Var v)
1294         -- SLPJ : disabling this to avoid proliferation of versions
1295         -- also works badly when thinking about seeding the loop
1296         -- from the body of the let
1297         --       f x y = letrec g z = ... in g (x,y)
1298         -- We don't want to specialise for that *particular* x,y
1299
1300   -- The default case: make a wild-card
1301 argToPat _in_scope _val_env arg _arg_occ
1302   = wildCardPat (exprType arg)
1303
1304 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1305 wildCardPat ty = do { uniq <- getUniqueUs
1306                     ; let id = mkSysLocal (fsLit "sc") uniq ty
1307                     ; return (False, Var id) }
1308
1309 argsToPats :: InScopeSet -> ValueEnv
1310            -> [(CoreArg, ArgOcc)]
1311            -> UniqSM [(Bool, CoreArg)]
1312 argsToPats in_scope val_env args
1313   = mapM do_one args
1314   where
1315     do_one (arg,occ) = argToPat in_scope val_env arg occ
1316 \end{code}
1317
1318
1319 \begin{code}
1320 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1321 isValue _env (Lit lit)
1322   = Just (ConVal (LitAlt lit) [])
1323
1324 isValue env (Var v)
1325   | Just stuff <- lookupVarEnv env v
1326   = Just stuff  -- You might think we could look in the idUnfolding here
1327                 -- but that doesn't take account of which branch of a
1328                 -- case we are in, which is the whole point
1329
1330   | not (isLocalId v) && isCheapUnfolding unf
1331   = isValue env (unfoldingTemplate unf)
1332   where
1333     unf = idUnfolding v
1334         -- However we do want to consult the unfolding
1335         -- as well, for let-bound constructors!
1336
1337 isValue env (Lam b e)
1338   | isTyVar b = case isValue env e of
1339                   Just _  -> Just LambdaVal
1340                   Nothing -> Nothing
1341   | otherwise = Just LambdaVal
1342
1343 isValue _env expr       -- Maybe it's a constructor application
1344   | (Var fun, args) <- collectArgs expr
1345   = case isDataConWorkId_maybe fun of
1346
1347         Just con | args `lengthAtLeast` dataConRepArity con
1348                 -- Check saturated; might be > because the
1349                 --                  arity excludes type args
1350                 -> Just (ConVal (DataAlt con) args)
1351
1352         _other | valArgCount args < idArity fun
1353                 -- Under-applied function
1354                -> Just LambdaVal        -- Partial application
1355
1356         _other -> Nothing
1357
1358 isValue _env _expr = Nothing
1359
1360 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1361 mk_con_app (LitAlt lit)  []   = Lit lit
1362 mk_con_app (DataAlt con) args = mkConApp con args
1363 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1364
1365 samePat :: CallPat -> CallPat -> Bool
1366 samePat (vs1, as1) (vs2, as2)
1367   = all2 same as1 as2
1368   where
1369     same (Var v1) (Var v2)
1370         | v1 `elem` vs1 = v2 `elem` vs2
1371         | v2 `elem` vs2 = False
1372         | otherwise     = v1 == v2
1373
1374     same (Lit l1)    (Lit l2)    = l1==l2
1375     same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1376
1377     same (Type {}) (Type {}) = True     -- Note [Ignore type differences]
1378     same (Note _ e1) e2 = same e1 e2    -- Ignore casts and notes
1379     same (Cast e1 _) e2 = same e1 e2
1380     same e1 (Note _ e2) = same e1 e2
1381     same e1 (Cast e2 _) = same e1 e2
1382
1383     same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1384                  False  -- Let, lambda, case should not occur
1385     bad (Case {}) = True
1386     bad (Let {})  = True
1387     bad (Lam {})  = True
1388     bad _other    = False
1389 \end{code}
1390
1391 Note [Ignore type differences]
1392 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1393 We do not want to generate specialisations where the call patterns
1394 differ only in their type arguments!  Not only is it utterly useless,
1395 but it also means that (with polymorphic recursion) we can generate
1396 an infinite number of specialisations. Example is Data.Sequence.adjustTree,
1397 I think.
1398