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