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 WwLib            ( mkWorkerArgs )
  26 import DataCon          ( dataConRepArity, dataConUnivTyVars )
  27 import Coercion
  28 import Rules
  29 import Type             hiding( substTy )
  30 import Id               ( Id, idName, idType, isDataConWorkId_maybe, idArity,
  31                           mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
  32 import Var
  33 import VarEnv
  34 import VarSet
  35 import Name
  36 import OccName          ( mkSpecOcc )
  37 import ErrUtils         ( dumpIfSet_dyn )
  38 import DynFlags         ( DynFlags(..), DynFlag(..) )
  39 import StaticFlags      ( opt_SpecInlineJoinPoints )
  40 import BasicTypes       ( Activation(..) )
  41 import Maybes           ( orElse, catMaybes, isJust, isNothing )
  42 import Util
  43 import List             ( nubBy, partition )
  44 import UniqSupply
  45 import Outputable
  46 import FastString
  47 import UniqFM
  48 import MonadUtils
  49 import Control.Monad    ( zipWithM )
  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 -----------------------------------------------------
 371                 Stuff not yet handled
 372 -----------------------------------------------------
 373
 374 Here are notes arising from Roman's work that I don't want to lose.
 375
 376 Example 1
 377 ~~~~~~~~~
 378     data T a = T !a
 379
 380     foo :: Int -> T Int -> Int
 381     foo 0 t = 0
 382     foo x t | even x    = case t of { T n -> foo (x-n) t }
 383             | otherwise = foo (x-1) t
 384
 385 SpecConstr does no specialisation, because the second recursive call
 386 looks like a boxed use of the argument.  A pity.
 387
 388     $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
 389     $wfoo_sFw =
 390       \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
 391          case ww_sFo of ds_Xw6 [Just L] {
 392            __DEFAULT ->
 393                 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
 394                   __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
 395                   0 ->
 396                     case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
 397                     case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
 398                     $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
 399                     } } };
 400            0 -> 0
 401
 402 Example 2
 403 ~~~~~~~~~
 404     data a :*: b = !a :*: !b
 405     data T a = T !a
 406
 407     foo :: (Int :*: T Int) -> Int
 408     foo (0 :*: t) = 0
 409     foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }
 410                   | otherwise = foo ((x-1) :*: t)
 411
 412 Very similar to the previous one, except that the parameters are now in
 413 a strict tuple. Before SpecConstr, we have
 414
 415     $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
 416     $wfoo_sG3 =
 417       \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
 418     GHC.Base.Int) ->
 419         case ww_sFU of ds_Xws [Just L] {
 420           __DEFAULT ->
 421         case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
 422           __DEFAULT ->
 423             case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
 424             $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1
 425             };
 426           0 ->
 427             case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
 428             case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
 429             $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2
 430             } } };
 431           0 -> 0 }
 432
 433 We get two specialisations:
 434 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
 435                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
 436                   = Foo.$s$wfoo1 a_sFB sc_sGC ;
 437 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
 438                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
 439                   = Foo.$s$wfoo y_aFp sc_sGC ;
 440
 441 But perhaps the first one isn't good.  After all, we know that tpl_B2 is
 442 a T (I# x) really, because T is strict and Int has one constructor.  (We can't
 443 unbox the strict fields, becuase T is polymorphic!)
 444
 445
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection{Top level wrapper stuff}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 \begin{code}
 454 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
 455 specConstrProgram dflags us binds
 456   = do
 457         showPass dflags "SpecConstr"
 458
 459         let (binds', _) = initUs us (go (initScEnv dflags) binds)
 460
 461         endPass dflags "SpecConstr" Opt_D_dump_spec binds'
 462
 463         dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
 464                       (pprRulesForUser (rulesOfBinds binds'))
 465
 466         return binds'
 467   where
 468     go _   []           = return []
 469     go env (bind:binds) = do (env', bind') <- scTopBind env bind
 470                              binds' <- go env' binds
 471                              return (bind' : binds')
 472 \end{code}
 473
 474
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsection{Environment: goes downwards}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 \begin{code}
 482 data ScEnv = SCE { sc_size  :: Maybe Int,       -- Size threshold
 483                    sc_count :: Maybe Int,       -- Max # of specialisations for any one fn
 484
 485                    sc_subst :: Subst,           -- Current substitution
 486                                                 -- Maps InIds to OutExprs
 487
 488                    sc_how_bound :: HowBoundEnv,
 489                         -- Binds interesting non-top-level variables
 490                         -- Domain is OutVars (*after* applying the substitution)
 491
 492                    sc_vals  :: ValueEnv
 493                         -- Domain is OutIds (*after* applying the substitution)
 494                         -- Used even for top-level bindings (but not imported ones)
 495              }
 496
 497 ---------------------
 498 -- As we go, we apply a substitution (sc_subst) to the current term
 499 type InExpr = CoreExpr          -- _Before_ applying the subst
 500
 501 type OutExpr = CoreExpr         -- _After_ applying the subst
 502 type OutId   = Id
 503 type OutVar  = Var
 504
 505 ---------------------
 506 type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars
 507
 508 ---------------------
 509 type ValueEnv = IdEnv Value             -- Domain is OutIds
 510 data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors
 511               | LambdaVal               -- Inlinable lambdas or PAPs
 512
 513 instance Outputable Value where
 514    ppr (ConVal con args) = ppr con <+> interpp'SP args
 515    ppr LambdaVal         = ptext (sLit "<Lambda>")
 516
 517 ---------------------
 518 initScEnv :: DynFlags -> ScEnv
 519 initScEnv dflags
 520   = SCE { sc_size = specConstrThreshold dflags,
 521           sc_count = specConstrCount dflags,
 522           sc_subst = emptySubst,
 523           sc_how_bound = emptyVarEnv,
 524           sc_vals = emptyVarEnv }
 525
 526 data HowBound = RecFun  -- These are the recursive functions for which
 527                         -- we seek interesting call patterns
 528
 529               | RecArg  -- These are those functions' arguments, or their sub-components;
 530                         -- we gather occurrence information for these
 531
 532 instance Outputable HowBound where
 533   ppr RecFun = text "RecFun"
 534   ppr RecArg = text "RecArg"
 535
 536 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
 537 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
 538
 539 scSubstId :: ScEnv -> Id -> CoreExpr
 540 scSubstId env v = lookupIdSubst (sc_subst env) v
 541
 542 scSubstTy :: ScEnv -> Type -> Type
 543 scSubstTy env ty = substTy (sc_subst env) ty
 544
 545 zapScSubst :: ScEnv -> ScEnv
 546 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
 547
 548 extendScInScope :: ScEnv -> [Var] -> ScEnv
 549         -- Bring the quantified variables into scope
 550 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
 551
 552         -- Extend the substitution
 553 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
 554 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
 555
 556 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
 557 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
 558
 559 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
 560 extendHowBound env bndrs how_bound
 561   = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
 562                             [(bndr,how_bound) | bndr <- bndrs] }
 563
 564 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
 565 extendBndrsWith how_bound env bndrs
 566   = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
 567   where
 568     (subst', bndrs') = substBndrs (sc_subst env) bndrs
 569     hb_env' = sc_how_bound env `extendVarEnvList`
 570                     [(bndr,how_bound) | bndr <- bndrs']
 571
 572 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
 573 extendBndrWith how_bound env bndr
 574   = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
 575   where
 576     (subst', bndr') = substBndr (sc_subst env) bndr
 577     hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
 578
 579 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
 580 extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')
 581                       where
 582                         (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
 583
 584 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
 585 extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')
 586                       where
 587                         (subst', bndr') = substBndr (sc_subst env) bndr
 588
 589 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
 590 extendValEnv env _  Nothing   = env
 591 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
 592
 593 extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
 594 -- When we encounter
 595 --      case scrut of b
 596 --          C x y -> ...
 597 -- we want to bind b, and perhaps scrut too, to (C x y)
 598 -- NB: Extends only the sc_vals part of the envt
 599 extendCaseBndrs env scrut case_bndr con alt_bndrs
 600   = case scrut of
 601         Var v  -> extendValEnv env1 v cval
 602         _other -> env1
 603  where
 604    env1 = extendValEnv env case_bndr cval
 605    cval = case con of
 606                 DEFAULT    -> Nothing
 607                 LitAlt {}  -> Just (ConVal con [])
 608                 DataAlt {} -> Just (ConVal con vanilla_args)
 609                       where
 610                         vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
 611                                        varsToCoreExprs alt_bndrs
 612 \end{code}
 613
 614
 615 %************************************************************************
 616 %*                                                                      *
 617 \subsection{Usage information: flows upwards}
 618 %*                                                                      *
 619 %************************************************************************
 620
 621 \begin{code}
 622 data ScUsage
 623    = SCU {
 624         scu_calls :: CallEnv,           -- Calls
 625                                         -- The functions are a subset of the
 626                                         --      RecFuns in the ScEnv
 627
 628         scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences
 629      }                                  -- The domain is OutIds
 630
 631 type CallEnv = IdEnv [Call]
 632 type Call = (ValueEnv, [CoreArg])
 633         -- The arguments of the call, together with the
 634         -- env giving the constructor bindings at the call site
 635
 636 nullUsage :: ScUsage
 637 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
 638
 639 combineCalls :: CallEnv -> CallEnv -> CallEnv
 640 combineCalls = plusVarEnv_C (++)
 641
 642 combineUsage :: ScUsage -> ScUsage -> ScUsage
 643 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
 644                            scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
 645
 646 combineUsages :: [ScUsage] -> ScUsage
 647 combineUsages [] = nullUsage
 648 combineUsages us = foldr1 combineUsage us
 649
 650 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
 651 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
 652   = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
 653      lookupVarEnv sc_occs bndr `orElse` NoOcc)
 654
 655 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
 656 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
 657   = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
 658      [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
 659
 660 data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument
 661             | UnkOcc    -- Used in some unknown way
 662
 663             | ScrutOcc (UniqFM [ArgOcc])        -- See Note [ScrutOcc]
 664
 665             | BothOcc   -- Definitely taken apart, *and* perhaps used in some other way
 666
 667 {-      Note  [ScrutOcc]
 668
 669 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
 670 is *only* taken apart or applied.
 671
 672   Functions, literal: ScrutOcc emptyUFM
 673   Data constructors:  ScrutOcc subs,
 674
 675 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
 676 The domain of the UniqFM is the Unique of the data constructor
 677
 678 The [ArgOcc] is the occurrences of the *pattern-bound* components
 679 of the data structure.  E.g.
 680         data T a = forall b. MkT a b (b->a)
 681 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
 682
 683 -}
 684
 685 instance Outputable ArgOcc where
 686   ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
 687   ppr UnkOcc        = ptext (sLit "unk-occ")
 688   ppr BothOcc       = ptext (sLit "both-occ")
 689   ppr NoOcc         = ptext (sLit "no-occ")
 690
 691 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
 692 -- that if the thing is scrutinised anywhere then we get to see that
 693 -- in the overall result, even if it's also used in a boxed way
 694 -- This might be too agressive; see Note [Reboxing] Alternative 3
 695 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
 696 combineOcc NoOcc         occ           = occ
 697 combineOcc occ           NoOcc         = occ
 698 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
 699 combineOcc _occ          (ScrutOcc ys) = ScrutOcc ys
 700 combineOcc (ScrutOcc xs) _occ          = ScrutOcc xs
 701 combineOcc UnkOcc        UnkOcc        = UnkOcc
 702 combineOcc _        _                  = BothOcc
 703
 704 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
 705 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
 706
 707 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
 708 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
 709 -- is a variable, and an interesting variable
 710 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
 711 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
 712 setScrutOcc env usg (Var v)    occ
 713   | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
 714   | otherwise                           = usg
 715 setScrutOcc _env usg _other _occ        -- Catch-all
 716   = usg
 717
 718 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
 719 -- Find usage of components of data con; returns [UnkOcc...] if unknown
 720 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
 721
 722 conArgOccs (ScrutOcc fm) (DataAlt dc)
 723   | Just pat_arg_occs <- lookupUFM fm dc
 724   = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
 725
 726 conArgOccs _other _con = repeat UnkOcc
 727 \end{code}
 728
 729 %************************************************************************
 730 %*                                                                      *
 731 \subsection{The main recursive function}
 732 %*                                                                      *
 733 %************************************************************************
 734
 735 The main recursive function gathers up usage information, and
 736 creates specialised versions of functions.
 737
 738 \begin{code}
 739 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
 740         -- The unique supply is needed when we invent
 741         -- a new name for the specialised function and its args
 742
 743 scExpr env e = scExpr' env e
 744
 745
 746 scExpr' env (Var v)     = case scSubstId env v of
 747                             Var v' -> return (varUsage env v' UnkOcc, Var v')
 748                             e'     -> scExpr (zapScSubst env) e'
 749
 750 scExpr' env (Type t)    = return (nullUsage, Type (scSubstTy env t))
 751 scExpr' _   e@(Lit {})  = return (nullUsage, e)
 752 scExpr' env (Note n e)  = do (usg,e') <- scExpr env e
 753                              return (usg, Note n e')
 754 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
 755                              return (usg, Cast e' (scSubstTy env co))
 756 scExpr' env e@(App _ _) = scApp env (collectArgs e)
 757 scExpr' env (Lam b e)   = do let (env', b') = extendBndr env b
 758                              (usg, e') <- scExpr env' e
 759                              return (usg, Lam b' e')
 760
 761 scExpr' env (Case scrut b ty alts)
 762   = do  { (scrut_usg, scrut') <- scExpr env scrut
 763         ; case isValue (sc_vals env) scrut' of
 764                 Just (ConVal con args) -> sc_con_app con args scrut'
 765                 _other                 -> sc_vanilla scrut_usg scrut'
 766         }
 767   where
 768     sc_con_app con args scrut'  -- Known constructor; simplify
 769         = do { let (_, bs, rhs) = findAlt con alts
 770                    alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
 771              ; scExpr alt_env' rhs }
 772
 773     sc_vanilla scrut_usg scrut' -- Normal case
 774      = do { let (alt_env,b') = extendBndrWith RecArg env b
 775                         -- Record RecArg for the components
 776
 777           ; (alt_usgs, alt_occs, alts')
 778                 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
 779
 780           ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
 781                 scrut_occ        = foldr combineOcc b_occ alt_occs
 782                 scrut_usg'       = setScrutOcc env scrut_usg scrut' scrut_occ
 783                 -- The combined usage of the scrutinee is given
 784                 -- by scrut_occ, which is passed to scScrut, which
 785                 -- in turn treats a bare-variable scrutinee specially
 786
 787           ; return (alt_usg `combineUsage` scrut_usg',
 788                     Case scrut' b' (scSubstTy env ty) alts') }
 789
 790     sc_alt env scrut' b' (con,bs,rhs)
 791       = do { let (env1, bs') = extendBndrsWith RecArg env bs
 792                  env2        = extendCaseBndrs env1 scrut' b' con bs'
 793            ; (usg,rhs') <- scExpr env2 rhs
 794            ; let (usg', arg_occs) = lookupOccs usg bs'
 795                  scrut_occ = case con of
 796                                 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
 797                                 _          -> ScrutOcc emptyUFM
 798            ; return (usg', scrut_occ, (con,bs',rhs')) }
 799
 800 scExpr' env (Let (NonRec bndr rhs) body)
 801   | isTyVar bndr        -- Type-lets may be created by doBeta
 802   = scExpr' (extendScSubst env bndr rhs) body
 803   | otherwise
 804   = do  { let (body_env, bndr') = extendBndr env bndr
 805         ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
 806         ; let rhs' = mkLams args' rhs_body'
 807
 808         ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
 809             do  {       -- Vanilla case
 810                   let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
 811                         -- Record if the RHS is a value
 812                 ; (body_usg, body') <- scExpr body_env2 body
 813                 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
 814           else  -- For now, just brutally inline the join point
 815             do { let body_env2 = extendScSubst env bndr rhs'
 816                ; scExpr body_env2 body } }
 817
 818
 819 {-  Old code
 820             do  {       -- Join-point case
 821                   let body_env2 = extendHowBound body_env [bndr'] RecFun
 822                         -- If the RHS of this 'let' contains calls
 823                         -- to recursive functions that we're trying
 824                         -- to specialise, then treat this let too
 825                         -- as one to specialise
 826                 ; (body_usg, body') <- scExpr body_env2 body
 827
 828                 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
 829
 830                 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
 831                           `combineUsage` rhs_usg `combineUsage` spec_usg,
 832                           mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
 833         }
 834 -}
 835
 836 -- A *local* recursive group: see Note [Local recursive groups]
 837 scExpr' env (Let (Rec prs) body)
 838   = do  { let (bndrs,rhss) = unzip prs
 839               (rhs_env1,bndrs') = extendRecBndrs env bndrs
 840               rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
 841
 842         ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
 843         ; (body_usg, body')     <- scExpr rhs_env2 body
 844
 845         -- NB: start specLoop from body_usg
 846         ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage
 847                                         [SI [] 0 (Just usg) | usg <- rhs_usgs]
 848
 849         ; let all_usg = spec_usg `combineUsage` body_usg
 850               bind'   = Rec (concat (zipWith specInfoBinds rhs_infos specs))
 851
 852         ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
 853                   Let bind' body') }
 854
 855 -----------------------------------
 856 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
 857
 858 scApp env (Var fn, args)        -- Function is a variable
 859   = ASSERT( not (null args) )
 860     do  { args_w_usgs <- mapM (scExpr env) args
 861         ; let (arg_usgs, args') = unzip args_w_usgs
 862               arg_usg = combineUsages arg_usgs
 863         ; case scSubstId env fn of
 864             fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
 865                         -- Do beta-reduction and try again
 866
 867             Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
 868                 where
 869                   fn_usg = case lookupHowBound env fn' of
 870                                 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
 871                                                      scu_occs  = emptyVarEnv }
 872                                 Just RecArg -> SCU { scu_calls = emptyVarEnv,
 873                                                      scu_occs  = unitVarEnv fn' (ScrutOcc emptyUFM) }
 874                                 Nothing     -> nullUsage
 875
 876
 877             other_fn' -> return (arg_usg, mkApps other_fn' args') }
 878                 -- NB: doing this ignores any usage info from the substituted
 879                 --     function, but I don't think that matters.  If it does
 880                 --     we can fix it.
 881   where
 882     doBeta :: OutExpr -> [OutExpr] -> OutExpr
 883     -- ToDo: adjust for System IF
 884     doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
 885     doBeta fn              args         = mkApps fn args
 886
 887 -- The function is almost always a variable, but not always.
 888 -- In particular, if this pass follows float-in,
 889 -- which it may, we can get
 890 --      (let f = ...f... in f) arg1 arg2
 891 scApp env (other_fn, args)
 892   = do  { (fn_usg,   fn')   <- scExpr env other_fn
 893         ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
 894         ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
 895
 896 ----------------------
 897 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
 898 scTopBind env (Rec prs)
 899   | Just threshold <- sc_size env
 900   , not (all (couldBeSmallEnoughToInline threshold) rhss)
 901                 -- No specialisation
 902   = do  { let (rhs_env,bndrs') = extendRecBndrs env bndrs
 903         ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
 904         ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
 905   | otherwise   -- Do specialisation
 906   = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
 907               rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
 908
 909         ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
 910         ; let rhs_usg = combineUsages rhs_usgs
 911
 912         ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage
 913                                  [SI [] 0 Nothing | _ <- bndrs]
 914
 915         ; return (rhs_env1,  -- For the body of the letrec, delete the RecFun business
 916                   Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
 917   where
 918     (bndrs,rhss) = unzip prs
 919
 920 scTopBind env (NonRec bndr rhs)
 921   = do  { (_, rhs') <- scExpr env rhs
 922         ; let (env1, bndr') = extendBndr env bndr
 923               env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
 924         ; return (env2, NonRec bndr' rhs') }
 925
 926 ----------------------
 927 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
 928 scRecRhs env (bndr,rhs)
 929   = do  { let (arg_bndrs,body) = collectBinders rhs
 930               (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
 931         ; (body_usg, body') <- scExpr body_env body
 932         ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
 933         ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
 934
 935                 -- The arg_occs says how the visible,
 936                 -- lambda-bound binders of the RHS are used
 937                 -- (including the TyVar binders)
 938                 -- Two pats are the same if they match both ways
 939
 940 ----------------------
 941 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
 942 specInfoBinds (fn, args, body, _) (SI specs _ _)
 943   = [(id,rhs) | OS _ _ id rhs <- specs] ++
 944     [(fn `addIdSpecialisations` rules, mkLams args body)]
 945   where
 946     rules = [r | OS _ r _ _ <- specs]
 947
 948 ----------------------
 949 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
 950 varUsage env v use
 951   | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
 952                                               , scu_occs = unitVarEnv v use }
 953   | otherwise                           = nullUsage
 954 \end{code}
 955
 956
 957 %************************************************************************
 958 %*                                                                      *
 959                 The specialiser itself
 960 %*                                                                      *
 961 %************************************************************************
 962
 963 \begin{code}
 964 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
 965         -- Info about the *original* RHS of a binding we are specialising
 966         -- Original binding f = \xs.body
 967         -- Plus info about usage of arguments
 968
 969 data SpecInfo = SI [OneSpec]            -- The specialisations we have generated
 970                    Int                  -- Length of specs; used for numbering them
 971                    (Maybe ScUsage)      -- Nothing => we have generated specialisations
 972                                         --            from calls in the *original* RHS
 973                                         -- Just cs => we haven't, and this is the usage
 974                                         --            of the original RHS
 975
 976         -- One specialisation: Rule plus definition
 977 data OneSpec  = OS CallPat              -- Call pattern that generated this specialisation
 978                    CoreRule             -- Rule connecting original id with the specialisation
 979                    OutId OutExpr        -- Spec id + its rhs
 980
 981
 982 specLoop :: ScEnv
 983          -> CallEnv
 984          -> [RhsInfo]
 985          -> ScUsage -> [SpecInfo]               -- One per binder; acccumulating parameter
 986          -> UniqSM (ScUsage, [SpecInfo])        -- ...ditto...
 987 specLoop env all_calls rhs_infos usg_so_far specs_so_far
 988   = do  { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
 989         ; let (new_usg_s, all_specs) = unzip specs_w_usg
 990               new_usg   = combineUsages new_usg_s
 991               new_calls = scu_calls new_usg
 992               all_usg   = usg_so_far `combineUsage` new_usg
 993         ; if isEmptyVarEnv new_calls then
 994                 return (all_usg, all_specs)
 995           else
 996                 specLoop env new_calls rhs_infos all_usg all_specs }
 997
 998 specialise
 999    :: ScEnv
1000    -> CallEnv                           -- Info on calls
1001    -> RhsInfo
1002    -> SpecInfo                          -- Original RHS plus patterns dealt with
1003    -> UniqSM (ScUsage, SpecInfo)        -- New specialised versions and their usage
1004
1005 -- Note: the rhs here is the optimised version of the original rhs
1006 -- So when we make a specialised copy of the RHS, we're starting
1007 -- from an RHS whose nested functions have been optimised already.
1008
1009 specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
1010                           spec_info@(SI specs spec_count mb_unspec)
1011   | notNull arg_bndrs,  -- Only specialise functions
1012     Just all_calls <- lookupVarEnv bind_calls fn
1013   = do  { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1014 --      ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
1015 --                                      text "calls" <+> ppr all_calls,
1016 --                                      text "good pats" <+> ppr pats])  $
1017 --        return ()
1018
1019                 -- Bale out if too many specialisations
1020                 -- Rather a hacky way to do so, but it'll do for now
1021         ; let spec_count' = length pats + spec_count
1022         ; case sc_count env of
1023             Just max | spec_count' > max
1024                 -> pprTrace "SpecConstr: too many specialisations for one function (see -fspec-constr-count):"
1025                          (vcat [ptext (sLit "Function:") <+> ppr fn,
1026                                 ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
1027                          return (nullUsage, spec_info)
1028
1029             _normal_case -> do {
1030
1031           (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1032                                                  (pats `zip` [spec_count..])
1033
1034         ; let spec_usg = combineUsages spec_usgs
1035               (new_usg, mb_unspec')
1036                   = case mb_unspec of
1037                       Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1038                       _                          -> (spec_usg,                      mb_unspec)
1039
1040         ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1041   | otherwise
1042   = return (nullUsage, spec_info)               -- The boring case
1043
1044
1045 ---------------------
1046 spec_one :: ScEnv
1047          -> OutId       -- Function
1048          -> [Var]       -- Lambda-binders of RHS; should match patterns
1049          -> CoreExpr    -- Body of the original function
1050          -> (CallPat, Int)
1051          -> UniqSM (ScUsage, OneSpec)   -- Rule and binding
1052
1053 -- spec_one creates a specialised copy of the function, together
1054 -- with a rule for using it.  I'm very proud of how short this
1055 -- function is, considering what it does :-).
1056
1057 {-
1058   Example
1059
1060      In-scope: a, x::a
1061      f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1062           [c::*, v::(b,c) are presumably bound by the (...) part]
1063   ==>
1064      f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1065                   (...entire body of f...) [b -> (b,c),
1066                                             y -> ((:) (a,(b,c)) (x,v) hw)]
1067
1068      RULE:  forall b::* c::*,           -- Note, *not* forall a, x
1069                    v::(b,c),
1070                    hw::[(a,(b,c))] .
1071
1072             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1073 -}
1074
1075 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1076   = do  {       -- Specialise the body
1077           let spec_env = extendScSubstList (extendScInScope env qvars)
1078                                            (arg_bndrs `zip` pats)
1079         ; (spec_usg, spec_body) <- scExpr spec_env body
1080
1081 --      ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1082 --                      text "calls" <+> (ppr (scu_calls spec_usg))])
1083 --        (return ())
1084
1085                 -- And build the results
1086         ; spec_uniq <- getUniqueUs
1087         ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1088                 -- Usual w/w hack to avoid generating
1089                 -- a spec_rhs of unlifted type and no args
1090
1091               fn_name   = idName fn
1092               fn_loc    = nameSrcSpan fn_name
1093               spec_occ  = mkSpecOcc (nameOccName fn_name)
1094               rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1095               spec_rhs  = mkLams spec_lam_args spec_body
1096               spec_id   = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1097               body_ty   = exprType spec_body
1098               rule_rhs  = mkVarApps (Var spec_id) spec_call_args
1099               rule      = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1100         ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1101
1102 -- In which phase should the specialise-constructor rules be active?
1103 -- Originally I made them always-active, but Manuel found that
1104 -- this defeated some clever user-written rules.  So Plan B
1105 -- is to make them active only in Phase 0; after all, currently,
1106 -- the specConstr transformation is only run after the simplifier
1107 -- has reached Phase 0.  In general one would want it to be
1108 -- flag-controllable, but for now I'm leaving it baked in
1109 --                                      [SLPJ Oct 01]
1110 specConstrActivation :: Activation
1111 specConstrActivation = ActiveAfter 0    -- Baked in; see comments above
1112 \end{code}
1113
1114 %************************************************************************
1115 %*                                                                      *
1116 \subsection{Argument analysis}
1117 %*                                                                      *
1118 %************************************************************************
1119
1120 This code deals with analysing call-site arguments to see whether
1121 they are constructor applications.
1122
1123
1124 \begin{code}
1125 type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments
1126
1127
1128 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1129         -- Result has no duplicate patterns,
1130         -- nor ones mentioned in done_pats
1131         -- Bool indicates that there was at least one boring pattern
1132 callsToPats env done_specs bndr_occs calls
1133   = do  { mb_pats <- mapM (callToPats env bndr_occs) calls
1134
1135         ; let good_pats :: [([Var], [CoreArg])]
1136               good_pats = catMaybes mb_pats
1137               done_pats = [p | OS p _ _ _ <- done_specs]
1138               is_done p = any (samePat p) done_pats
1139
1140         ; return (any isNothing mb_pats,
1141                   filterOut is_done (nubBy samePat good_pats)) }
1142
1143 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1144         -- The [Var] is the variables to quantify over in the rule
1145         --      Type variables come first, since they may scope
1146         --      over the following term variables
1147         -- The [CoreExpr] are the argument patterns for the rule
1148 callToPats env bndr_occs (con_env, args)
1149   | length args < length bndr_occs      -- Check saturated
1150   = return Nothing
1151   | otherwise
1152   = do  { let in_scope = substInScope (sc_subst env)
1153         ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1154         ; let (interesting_s, pats) = unzip prs
1155               pat_fvs = varSetElems (exprsFreeVars pats)
1156               qvars   = filterOut (`elemInScopeSet` in_scope) pat_fvs
1157                 -- Quantify over variables that are not in sccpe
1158                 -- at the call site
1159                 -- See Note [Shadowing] at the top
1160
1161               (tvs, ids) = partition isTyVar qvars
1162               qvars'     = tvs ++ ids
1163                 -- Put the type variables first; the type of a term
1164                 -- variable may mention a type variable
1165
1166         ; -- pprTrace "callToPats"  (ppr args $$ ppr prs $$ ppr bndr_occs) $
1167           if or interesting_s
1168           then return (Just (qvars', pats))
1169           else return Nothing }
1170
1171     -- argToPat takes an actual argument, and returns an abstracted
1172     -- version, consisting of just the "constructor skeleton" of the
1173     -- argument, with non-constructor sub-expression replaced by new
1174     -- placeholder variables.  For example:
1175     --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
1176
1177 argToPat :: InScopeSet                  -- What's in scope at the fn defn site
1178          -> ValueEnv                    -- ValueEnv at the call site
1179          -> CoreArg                     -- A call arg (or component thereof)
1180          -> ArgOcc
1181          -> UniqSM (Bool, CoreArg)
1182 -- Returns (interesting, pat),
1183 -- where pat is the pattern derived from the argument
1184 --            intersting=True if the pattern is non-trivial (not a variable or type)
1185 -- E.g.         x:xs         --> (True, x:xs)
1186 --              f xs         --> (False, w)        where w is a fresh wildcard
1187 --              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
1188 --              \x. x+y      --> (True, \x. x+y)
1189 --              lvl7         --> (True, lvl7)      if lvl7 is bound
1190 --                                                 somewhere further out
1191
1192 argToPat _in_scope _val_env arg@(Type {}) _arg_occ
1193   = return (False, arg)
1194
1195 argToPat in_scope val_env (Note _ arg) arg_occ
1196   = argToPat in_scope val_env arg arg_occ
1197         -- Note [Notes in call patterns]
1198         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1199         -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
1200         -- Perhaps we should not ignore profiling notes, but I'm going to
1201         -- ride roughshod over them all for now.
1202         --- See Note [Notes in RULE matching] in Rules
1203
1204 argToPat in_scope val_env (Let _ arg) arg_occ
1205   = argToPat in_scope val_env arg arg_occ
1206         -- Look through let expressions
1207         -- e.g.         f (let v = rhs in \y -> ...v...)
1208         -- Here we can specialise for f (\y -> ...)
1209         -- because the rule-matcher will look through the let.
1210
1211 argToPat in_scope val_env (Cast arg co) arg_occ
1212   = do  { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1213         ; let (ty1,ty2) = coercionKind co
1214         ; if not interesting then
1215                 wildCardPat ty2
1216           else do
1217         { -- Make a wild-card pattern for the coercion
1218           uniq <- getUniqueUs
1219         ; let co_name = mkSysTvName uniq (fsLit "sg")
1220               co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1221         ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1222
1223 {-      Disabling lambda specialisation for now
1224         It's fragile, and the spec_loop can be infinite
1225 argToPat in_scope val_env arg arg_occ
1226   | is_value_lam arg
1227   = return (True, arg)
1228   where
1229     is_value_lam (Lam v e)      -- Spot a value lambda, even if
1230         | isId v = True         -- it is inside a type lambda
1231         | otherwise = is_value_lam e
1232     is_value_lam other = False
1233 -}
1234
1235   -- Check for a constructor application
1236   -- NB: this *precedes* the Var case, so that we catch nullary constrs
1237 argToPat in_scope val_env arg arg_occ
1238   | Just (ConVal dc args) <- isValue val_env arg
1239   , case arg_occ of
1240         ScrutOcc _ -> True              -- Used only by case scrutinee
1241         BothOcc    -> case arg of       -- Used elsewhere
1242                         App {} -> True  --     see Note [Reboxing]
1243                         _other -> False
1244         _other     -> False     -- No point; the arg is not decomposed
1245   = do  { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1246         ; return (True, mk_con_app dc (map snd args')) }
1247
1248   -- Check if the argument is a variable that
1249   -- is in scope at the function definition site
1250   -- It's worth specialising on this if
1251   --    (a) it's used in an interesting way in the body
1252   --    (b) we know what its value is
1253 argToPat in_scope val_env (Var v) arg_occ
1254   | case arg_occ of { UnkOcc -> False; _other -> True },        -- (a)
1255     is_value                                                    -- (b)
1256   = return (True, Var v)
1257   where
1258     is_value
1259         | isLocalId v = v `elemInScopeSet` in_scope
1260                         && isJust (lookupVarEnv val_env v)
1261                 -- Local variables have values in val_env
1262         | otherwise   = isValueUnfolding (idUnfolding v)
1263                 -- Imports have unfoldings
1264
1265 --      I'm really not sure what this comment means
1266 --      And by not wild-carding we tend to get forall'd
1267 --      variables that are in soope, which in turn can
1268 --      expose the weakness in let-matching
1269 --      See Note [Matching lets] in Rules
1270
1271   -- Check for a variable bound inside the function.
1272   -- Don't make a wild-card, because we may usefully share
1273   --    e.g.  f a = let x = ... in f (x,x)
1274   -- NB: this case follows the lambda and con-app cases!!
1275 -- argToPat _in_scope _val_env (Var v) _arg_occ
1276 --   = return (False, Var v)
1277         -- SLPJ : disabling this to avoid proliferation of versions
1278         -- also works badly when thinking about seeding the loop
1279         -- from the body of the let
1280         --       f x y = letrec g z = ... in g (x,y)
1281         -- We don't want to specialise for that *particular* x,y
1282
1283   -- The default case: make a wild-card
1284 argToPat _in_scope _val_env arg _arg_occ
1285   = wildCardPat (exprType arg)
1286
1287 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1288 wildCardPat ty = do { uniq <- getUniqueUs
1289                     ; let id = mkSysLocal (fsLit "sc") uniq ty
1290                     ; return (False, Var id) }
1291
1292 argsToPats :: InScopeSet -> ValueEnv
1293            -> [(CoreArg, ArgOcc)]
1294            -> UniqSM [(Bool, CoreArg)]
1295 argsToPats in_scope val_env args
1296   = mapM do_one args
1297   where
1298     do_one (arg,occ) = argToPat in_scope val_env arg occ
1299 \end{code}
1300
1301
1302 \begin{code}
1303 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1304 isValue _env (Lit lit)
1305   = Just (ConVal (LitAlt lit) [])
1306
1307 isValue env (Var v)
1308   | Just stuff <- lookupVarEnv env v
1309   = Just stuff  -- You might think we could look in the idUnfolding here
1310                 -- but that doesn't take account of which branch of a
1311                 -- case we are in, which is the whole point
1312
1313   | not (isLocalId v) && isCheapUnfolding unf
1314   = isValue env (unfoldingTemplate unf)
1315   where
1316     unf = idUnfolding v
1317         -- However we do want to consult the unfolding
1318         -- as well, for let-bound constructors!
1319
1320 isValue env (Lam b e)
1321   | isTyVar b = case isValue env e of
1322                   Just _  -> Just LambdaVal
1323                   Nothing -> Nothing
1324   | otherwise = Just LambdaVal
1325
1326 isValue _env expr       -- Maybe it's a constructor application
1327   | (Var fun, args) <- collectArgs expr
1328   = case isDataConWorkId_maybe fun of
1329
1330         Just con | args `lengthAtLeast` dataConRepArity con
1331                 -- Check saturated; might be > because the
1332                 --                  arity excludes type args
1333                 -> Just (ConVal (DataAlt con) args)
1334
1335         _other | valArgCount args < idArity fun
1336                 -- Under-applied function
1337                -> Just LambdaVal        -- Partial application
1338
1339         _other -> Nothing
1340
1341 isValue _env _expr = Nothing
1342
1343 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1344 mk_con_app (LitAlt lit)  []   = Lit lit
1345 mk_con_app (DataAlt con) args = mkConApp con args
1346 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1347
1348 samePat :: CallPat -> CallPat -> Bool
1349 samePat (vs1, as1) (vs2, as2)
1350   = all2 same as1 as2
1351   where
1352     same (Var v1) (Var v2)
1353         | v1 `elem` vs1 = v2 `elem` vs2
1354         | v2 `elem` vs2 = False
1355         | otherwise     = v1 == v2
1356
1357     same (Lit l1)    (Lit l2)    = l1==l2
1358     same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1359
1360     same (Type {}) (Type {}) = True     -- Note [Ignore type differences]
1361     same (Note _ e1) e2 = same e1 e2    -- Ignore casts and notes
1362     same (Cast e1 _) e2 = same e1 e2
1363     same e1 (Note _ e2) = same e1 e2
1364     same e1 (Cast e2 _) = same e1 e2
1365
1366     same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1367                  False  -- Let, lambda, case should not occur
1368     bad (Case {}) = True
1369     bad (Let {})  = True
1370     bad (Lam {})  = True
1371     bad _other    = False
1372 \end{code}
1373
1374 Note [Ignore type differences]
1375 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1376 We do not want to generate specialisations where the call patterns
1377 differ only in their type arguments!  Not only is it utterly useless,
1378 but it also means that (with polymorphic recursion) we can generate
1379 an infinite number of specialisations. Example is Data.Sequence.adjustTree,
1380 I think.
1381