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