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