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