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