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