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 CoreLint         ( showPass, endPass )
  15 import CoreUtils        ( exprType, mkPiTypes )
  16 import CoreFVs          ( exprsFreeVars )
  17 import CoreSubst        ( Subst, mkSubst, substExpr )
  18 import CoreTidy         ( tidyRules )
  19 import PprCore          ( pprRules )
  20 import WwLib            ( mkWorkerArgs )
  21 import DataCon          ( dataConRepArity, isVanillaDataCon, dataConTyVars )
  22 import Type             ( Type, tyConAppArgs, tyVarsOfTypes )
  23 import Rules            ( matchN )
  24 import Unify            ( coreRefineTys )
  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, isJust )
  37 import Util             ( zipWithEqual, lengthAtLeast, notNull )
  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: 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
 130 Note [Good arguments]
 131 ~~~~~~~~~~~~~~~~~~~~~
 132 So we look for
 133
 134 * A self-recursive function.  Ignore mutual recursion for now,
 135   because it's less common, and the code is simpler for self-recursion.
 136
 137 * EITHER
 138
 139    a) At a recursive call, one or more parameters is an explicit
 140       constructor application
 141         AND
 142       That same parameter is scrutinised by a case somewhere in
 143       the RHS of the function
 144
 145   OR
 146
 147     b) At a recursive call, one or more parameters has an unfolding
 148        that is an explicit constructor application
 149         AND
 150       That same parameter is scrutinised by a case somewhere in
 151       the RHS of the function
 152         AND
 153       Those are the only uses of the parameter (see Note [Reboxing])
 154
 155
 156 What to abstract over
 157 ~~~~~~~~~~~~~~~~~~~~~
 158 There's a bit of a complication with type arguments.  If the call
 159 site looks like
 160
 161         f p = ...f ((:) [a] x xs)...
 162
 163 then our specialised function look like
 164
 165         f_spec x xs = let p = (:) [a] x xs in ....as before....
 166
 167 This only makes sense if either
 168   a) the type variable 'a' is in scope at the top of f, or
 169   b) the type variable 'a' is an argument to f (and hence fs)
 170
 171 Actually, (a) may hold for value arguments too, in which case
 172 we may not want to pass them.  Supose 'x' is in scope at f's
 173 defn, but xs is not.  Then we'd like
 174
 175         f_spec xs = let p = (:) [a] x xs in ....as before....
 176
 177 Similarly (b) may hold too.  If x is already an argument at the
 178 call, no need to pass it again.
 179
 180 Finally, if 'a' is not in scope at the call site, we could abstract
 181 it as we do the term variables:
 182
 183         f_spec a x xs = let p = (:) [a] x xs in ...as before...
 184
 185 So the grand plan is:
 186
 187         * abstract the call site to a constructor-only pattern
 188           e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)
 189
 190         * Find the free variables of the abstracted pattern
 191
 192         * Pass these variables, less any that are in scope at
 193           the fn defn.  But see Note [Shadowing] below.
 194
 195
 196 NOTICE that we only abstract over variables that are not in scope,
 197 so we're in no danger of shadowing variables used in "higher up"
 198 in f_spec's RHS.
 199
 200
 201 Note [Shadowing]
 202 ~~~~~~~~~~~~~~~~
 203 In this pass we gather up usage information that may mention variables
 204 that are bound between the usage site and the definition site; or (more
 205 seriously) may be bound to something different at the definition site.
 206 For example:
 207
 208         f x = letrec g y v = let x = ...
 209                              in ...(g (a,b) x)...
 210
 211 Since 'x' is in scope at the call site, we may make a rewrite rule that
 212 looks like
 213         RULE forall a,b. g (a,b) x = ...
 214 But this rule will never match, because it's really a different 'x' at
 215 the call site -- and that difference will be manifest by the time the
 216 simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*
 217 no-shadowing, so perhaps it may not be distinct?]
 218
 219 Anyway, the rule isn't actually wrong, it's just not useful.  One possibility
 220 is to run deShadowBinds before running SpecConstr, but instead we run the
 221 simplifier.  That gives the simplest possible program for SpecConstr to
 222 chew on; and it virtually guarantees no shadowing.
 223
 224 Note [Specialising for constant parameters]
 225 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 226 This one is about specialising on a *constant* (but not necessarily
 227 constructor) argument
 228
 229     foo :: Int -> (Int -> Int) -> Int
 230     foo 0 f = 0
 231     foo m f = foo (f m) (+1)
 232
 233 It produces
 234
 235     lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
 236     lvl_rmV =
 237       \ (ds_dlk :: GHC.Base.Int) ->
 238         case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
 239         GHC.Base.I# (GHC.Prim.+# x_alG 1)
 240
 241     T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
 242     GHC.Prim.Int#
 243     T.$wfoo =
 244       \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
 245         case ww_sme of ds_Xlw {
 246           __DEFAULT ->
 247         case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
 248         T.$wfoo ww1_Xmz lvl_rmV
 249         };
 250           0 -> 0
 251         }
 252
 253 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
 254 with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.
 255
 256 When is this worth it?  Call the constant 'lvl'
 257 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
 258   parameter is scrutinised anywhere in the body.
 259
 260 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
 261   parameter is applied (...to enough arguments...?)
 262
 263   Also do this is if the function has RULES?
 264
 265 Also
 266
 267 Note [Specialising for lambda parameters]
 268 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 269     foo :: Int -> (Int -> Int) -> Int
 270     foo 0 f = 0
 271     foo m f = foo (f m) (\n -> n-m)
 272
 273 This is subtly different from the previous one in that we get an
 274 explicit lambda as the argument:
 275
 276     T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
 277     GHC.Prim.Int#
 278     T.$wfoo =
 279       \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
 280         case ww_sm8 of ds_Xlr {
 281           __DEFAULT ->
 282         case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
 283         T.$wfoo
 284           ww1_Xmq
 285           (\ (n_ad3 :: GHC.Base.Int) ->
 286              case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
 287              GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
 288              })
 289         };
 290           0 -> 0
 291         }
 292
 293 I wonder if SpecConstr couldn't be extended to handle this? After all,
 294 lambda is a sort of constructor for functions and perhaps it already
 295 has most of the necessary machinery?
 296
 297 Furthermore, there's an immediate win, because you don't need to allocate the lamda
 298 at the call site; and if perchance it's called in the recursive call, then you
 299 may avoid allocating it altogether.  Just like for constructors.
 300
 301 Looks cool, but probably rare...but it might be easy to implement.
 302
 303 -----------------------------------------------------
 304                 Stuff not yet handled
 305 -----------------------------------------------------
 306
 307 Here are notes arising from Roman's work that I don't want to lose.
 308
 309 Example 1
 310 ~~~~~~~~~
 311     data T a = T !a
 312
 313     foo :: Int -> T Int -> Int
 314     foo 0 t = 0
 315     foo x t | even x    = case t of { T n -> foo (x-n) t }
 316             | otherwise = foo (x-1) t
 317
 318 SpecConstr does no specialisation, because the second recursive call
 319 looks like a boxed use of the argument.  A pity.
 320
 321     $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
 322     $wfoo_sFw =
 323       \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
 324          case ww_sFo of ds_Xw6 [Just L] {
 325            __DEFAULT ->
 326                 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
 327                   __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
 328                   0 ->
 329                     case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
 330                     case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
 331                     $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
 332                     } } };
 333            0 -> 0
 334
 335 Example 2
 336 ~~~~~~~~~
 337     data a :*: b = !a :*: !b
 338     data T a = T !a
 339
 340     foo :: (Int :*: T Int) -> Int
 341     foo (0 :*: t) = 0
 342     foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }
 343                   | otherwise = foo ((x-1) :*: t)
 344
 345 Very similar to the previous one, except that the parameters are now in
 346 a strict tuple. Before SpecConstr, we have
 347
 348     $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
 349     $wfoo_sG3 =
 350       \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
 351     GHC.Base.Int) ->
 352         case ww_sFU of ds_Xws [Just L] {
 353           __DEFAULT ->
 354         case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
 355           __DEFAULT ->
 356             case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
 357             $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1
 358             };
 359           0 ->
 360             case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
 361             case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
 362             $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2
 363             } } };
 364           0 -> 0 }
 365
 366 We get two specialisations:
 367 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
 368                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
 369                   = Foo.$s$wfoo1 a_sFB sc_sGC ;
 370 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
 371                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
 372                   = Foo.$s$wfoo y_aFp sc_sGC ;
 373
 374 But perhaps the first one isn't good.  After all, we know that tpl_B2 is
 375 a T (I# x) really, because T is strict and Int has one constructor.  (We can't
 376 unbox the strict fields, becuase T is polymorphic!)
 377
 378
 379
 380 %************************************************************************
 381 %*                                                                      *
 382 \subsection{Top level wrapper stuff}
 383 %*                                                                      *
 384 %************************************************************************
 385
 386 \begin{code}
 387 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
 388 specConstrProgram dflags us binds
 389   = do
 390         showPass dflags "SpecConstr"
 391
 392         let (binds', _) = initUs us (go emptyScEnv binds)
 393
 394         endPass dflags "SpecConstr" Opt_D_dump_spec binds'
 395
 396         dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
 397                   (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
 398
 399         return binds'
 400   where
 401     go env []           = returnUs []
 402     go env (bind:binds) = scBind env bind       `thenUs` \ (env', _, bind') ->
 403                           go env' binds         `thenUs` \ binds' ->
 404                           returnUs (bind' : binds')
 405 \end{code}
 406
 407
 408 %************************************************************************
 409 %*                                                                      *
 410 \subsection{Environment: goes downwards}
 411 %*                                                                      *
 412 %************************************************************************
 413
 414 \begin{code}
 415 data ScEnv = SCE { scope :: InScopeEnv,
 416                         -- Binds all non-top-level variables in scope
 417
 418                    cons  :: ConstrEnv
 419              }
 420
 421 type InScopeEnv = VarEnv HowBound
 422
 423 type ConstrEnv = IdEnv ConValue
 424 data ConValue  = CV AltCon [CoreArg]
 425         -- Variables known to be bound to a constructor
 426         -- in a particular case alternative
 427
 428
 429 instance Outputable ConValue where
 430    ppr (CV con args) = ppr con <+> interpp'SP args
 431
 432 refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv
 433 -- The substitution is a type substitution only
 434 refineConstrEnv subst env = mapVarEnv refine_con_value env
 435   where
 436     refine_con_value (CV con args) = CV con (map (substExpr subst) args)
 437
 438 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
 439
 440 data HowBound = RecFun  -- These are the recursive functions for which
 441                         -- we seek interesting call patterns
 442
 443               | RecArg  -- These are those functions' arguments, or their sub-components;
 444                         -- we gather occurrence information for these
 445
 446               | Other   -- We track all others so we know what's in scope
 447                         -- This is used in spec_one to check what needs to be
 448                         -- passed as a parameter and what is in scope at the
 449                         -- function definition site
 450
 451 instance Outputable HowBound where
 452   ppr RecFun = text "RecFun"
 453   ppr RecArg = text "RecArg"
 454   ppr Other = text "Other"
 455
 456 lookupScopeEnv env v = lookupVarEnv (scope env) v
 457
 458 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
 459 extendBndr  env bndr  = env { scope = extendVarEnv (scope env) bndr Other }
 460
 461     -- When we encounter
 462     --  case scrut of b
 463     --      C x y -> ...
 464     -- we want to bind b, and perhaps scrut too, to (C x y)
 465 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
 466 extendCaseBndrs env case_bndr scrut con alt_bndrs
 467   = case con of
 468         DEFAULT    -> env1
 469         LitAlt lit -> extendCons env1 scrut case_bndr (CV con [])
 470         DataAlt dc -> extend_data_con dc
 471   where
 472     cur_scope = scope env
 473     env1 = env { scope = extendVarEnvList cur_scope
 474                                 [(b,how_bound) | b <- case_bndr:alt_bndrs] }
 475
 476         -- Record RecArg for the components iff the scrutinee is RecArg
 477         --      [This comment looks plain wrong to me, so I'm ignoring it
 478         --           "Also forget if the scrutinee is a RecArg, because we're
 479         --           now in the branch of a case, and we don't want to
 480         --           record a non-scrutinee use of v if we have
 481         --              case v of { (a,b) -> ...(f v)... }" ]
 482     how_bound = case scrut of
 483                   Var v -> lookupVarEnv cur_scope v `orElse` Other
 484                   other -> Other
 485
 486     extend_data_con data_con
 487         | isVanillaDataCon data_con = extendCons env1 scrut case_bndr (CV con vanilla_args)
 488         | otherwise                 = extendCons env2 scrut case_bndr (CV con gadt_args)
 489                 -- Note env2 for GADTs
 490         where
 491
 492             vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
 493                            map varToCoreExpr alt_bndrs
 494
 495             gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
 496                 -- This call generates some bogus warnings from substExpr,
 497                 -- because it's inconvenient to put all the Ids in scope
 498                 -- Will be fixed when we move to FC
 499
 500             (alt_tvs, _) = span isTyVar alt_bndrs
 501             Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
 502             subst = mkSubst in_scope tv_subst emptyVarEnv       -- No Id substitition
 503             in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
 504
 505             env2 | is_local  = env1
 506                  | otherwise = env1 { cons = refineConstrEnv subst (cons env) }
 507
 508
 509 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
 510 extendCons env scrut case_bndr val
 511   = case scrut of
 512         Var v -> env { cons = extendVarEnv cons1 v val }
 513         other -> env { cons = cons1 }
 514   where
 515     cons1 = extendVarEnv (cons env) case_bndr val
 516
 517     -- When we encounter a recursive function binding
 518     --  f = \x y -> ...
 519     -- we want to extend the scope env with bindings
 520     -- that record that f is a RecFn and x,y are RecArgs
 521 extendRecBndr env fn bndrs
 522   =  env { scope = scope env `extendVarEnvList`
 523                    ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
 524 \end{code}
 525
 526
 527 %************************************************************************
 528 %*                                                                      *
 529 \subsection{Usage information: flows upwards}
 530 %*                                                                      *
 531 %************************************************************************
 532
 533 \begin{code}
 534 data ScUsage
 535    = SCU {
 536         calls :: !(IdEnv ([Call])),     -- Calls
 537                                         -- The functions are a subset of the
 538                                         --      RecFuns in the ScEnv
 539
 540         occs :: !(IdEnv ArgOcc)         -- Information on argument occurrences
 541      }                                  -- The variables are a subset of the
 542                                         --      RecArg in the ScEnv
 543
 544 type Call = (ConstrEnv, [CoreArg])
 545         -- The arguments of the call, together with the
 546         -- env giving the constructor bindings at the call site
 547
 548 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
 549
 550 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
 551                            occs  = plusVarEnv_C combineOcc (occs u1) (occs u2) }
 552
 553 combineUsages [] = nullUsage
 554 combineUsages us = foldr1 combineUsage us
 555
 556 lookupOcc :: ScUsage -> Var -> (ScUsage, ArgOcc)
 557 lookupOcc (SCU { calls = sc_calls, occs = sc_occs }) bndr
 558   = (SCU {calls = sc_calls, occs = delVarEnv sc_occs bndr},
 559      lookupVarEnv sc_occs bndr `orElse` NoOcc)
 560
 561 lookupOccs :: ScUsage -> [Var] -> (ScUsage, [ArgOcc])
 562 lookupOccs (SCU { calls = sc_calls, occs = sc_occs }) bndrs
 563   = (SCU {calls = sc_calls, occs = delVarEnvList sc_occs bndrs},
 564      [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
 565
 566 data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument
 567             | UnkOcc    -- Used in some unknown way
 568
 569             | ScrutOcc (UniqFM [ArgOcc])        -- See Note [ScrutOcc]
 570
 571             | BothOcc   -- Definitely taken apart, *and* perhaps used in some other way
 572
 573 {-      Note  [ScrutOcc]
 574
 575 An occurrence of ScrutOcc indicates that the thing is *only* taken apart or applied.
 576
 577   Functions, litersl: ScrutOcc emptyUFM
 578   Data constructors:  ScrutOcc subs,
 579
 580 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
 581 The domain of the UniqFM is the Unique of the data constructor
 582
 583 The [ArgOcc] is the occurrences of the *pattern-bound* components
 584 of the data structure.  E.g.
 585         data T a = forall b. MkT a b (b->a)
 586 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
 587
 588 -}
 589
 590 instance Outputable ArgOcc where
 591   ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> parens (ppr xs)
 592   ppr UnkOcc        = ptext SLIT("unk-occ")
 593   ppr BothOcc       = ptext SLIT("both-occ")
 594   ppr NoOcc         = ptext SLIT("no-occ")
 595
 596 combineOcc NoOcc         occ           = occ
 597 combineOcc occ           NoOcc         = occ
 598 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
 599 combineOcc UnkOcc        UnkOcc        = UnkOcc
 600 combineOcc _        _                  = BothOcc
 601
 602 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
 603 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
 604
 605 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
 606 -- Find usage of components of data con; returns [UnkOcc...] if unknown
 607 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
 608
 609 conArgOccs (ScrutOcc fm) (DataAlt dc)
 610   | Just pat_arg_occs <- lookupUFM fm dc
 611   = tyvar_unks ++ pat_arg_occs
 612   where
 613     tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConTyVars dc]
 614                | otherwise           = []
 615
 616 conArgOccs other con = repeat UnkOcc
 617 \end{code}
 618
 619
 620 %************************************************************************
 621 %*                                                                      *
 622 \subsection{The main recursive function}
 623 %*                                                                      *
 624 %************************************************************************
 625
 626 The main recursive function gathers up usage information, and
 627 creates specialised versions of functions.
 628
 629 \begin{code}
 630 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
 631         -- The unique supply is needed when we invent
 632         -- a new name for the specialised function and its args
 633
 634 scExpr env e@(Type t) = returnUs (nullUsage, e)
 635 scExpr env e@(Lit l)  = returnUs (nullUsage, e)
 636 scExpr env e@(Var v)  = returnUs (varUsage env v UnkOcc, e)
 637 scExpr env (Note n e) = scExpr env e    `thenUs` \ (usg,e') ->
 638                         returnUs (usg, Note n e')
 639 scExpr env (Lam b e)  = scExpr (extendBndr env b) e     `thenUs` \ (usg,e') ->
 640                         returnUs (usg, Lam b e')
 641
 642 scExpr env (Case scrut b ty alts)
 643   = do  { (alt_usgs, alt_occs, alts') <- mapAndUnzip3Us sc_alt alts
 644         ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b
 645               scrut_occ = foldr combineOcc b_occ alt_occs
 646                 -- The combined usage of the scrutinee is given
 647                 -- by scrut_occ, which is passed to scScrut, which
 648                 -- in turn treats a bare-variable scrutinee specially
 649         ; (scrut_usg, scrut') <- scScrut env scrut scrut_occ
 650         ; return (alt_usg `combineUsage` scrut_usg,
 651                   Case scrut' b ty alts') }
 652   where
 653     sc_alt (con,bs,rhs)
 654       = do { let env1 = extendCaseBndrs env b scrut con bs
 655            ; (usg,rhs') <- scExpr env1 rhs
 656            ; let (usg', arg_occs) = lookupOccs usg bs
 657                  scrut_occ = case con of
 658                                 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
 659                                 other      -> ScrutOcc emptyUFM
 660            ; return (usg', scrut_occ, (con,bs,rhs')) }
 661
 662 scExpr env (Let bind body)
 663   = scBind env bind     `thenUs` \ (env', bind_usg, bind') ->
 664     scExpr env' body    `thenUs` \ (body_usg, body') ->
 665     returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
 666
 667 scExpr env e@(App _ _)
 668   = do  { let (fn, args) = collectArgs e
 669         ; (fn_usg, fn') <- scScrut env fn (ScrutOcc emptyUFM)
 670         -- Process the function too.   It's almost always a variable,
 671         -- but not always.  In particular, if this pass follows float-in,
 672         -- which it may, we can get
 673         --      (let f = ...f... in f) arg1 arg2
 674         -- We use scScrut to record the fact that the function is called
 675         -- Perhpas we should check that it has at least one value arg,
 676         -- but currently we don't bother
 677
 678         ; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args
 679         ; let call_usg = case fn of
 680                            Var f | Just RecFun <- lookupScopeEnv env f
 681                                  -> SCU { calls = unitVarEnv f [(cons env, args)],
 682                                           occs  = emptyVarEnv }
 683                            other -> nullUsage
 684         ; return (combineUsages arg_usgs `combineUsage` fn_usg
 685                                          `combineUsage` call_usg,
 686                   mkApps fn' args') }
 687
 688
 689 ----------------------
 690 scScrut :: ScEnv -> CoreExpr -> ArgOcc -> UniqSM (ScUsage, CoreExpr)
 691 -- Used for the scrutinee of a case,
 692 -- or the function of an application
 693 scScrut env e@(Var v) occ = returnUs (varUsage env v occ, e)
 694 scScrut env e         occ = scExpr env e
 695
 696
 697 ----------------------
 698 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
 699 scBind env (Rec [(fn,rhs)])
 700   | notNull val_bndrs
 701   = scExpr env_fn_body body             `thenUs` \ (usg, body') ->
 702     specialise env fn bndrs body' usg   `thenUs` \ (rules, spec_prs) ->
 703         -- Note body': the specialised copies should be based on the
 704         --             optimised version of the body, in case there were
 705         --             nested functions inside.
 706     let
 707         SCU { calls = calls, occs = occs } = usg
 708     in
 709     returnUs (extendBndr env fn,        -- For the body of the letrec, just
 710                                         -- extend the env with Other to record
 711                                         -- that it's in scope; no funny RecFun business
 712               SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
 713               Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
 714   where
 715     (bndrs,body) = collectBinders rhs
 716     val_bndrs    = filter isId bndrs
 717     env_fn_body  = extendRecBndr env fn bndrs
 718
 719 scBind env (Rec prs)
 720   = mapAndUnzipUs do_one prs    `thenUs` \ (usgs, prs') ->
 721     returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
 722   where
 723     do_one (bndr,rhs) = scExpr env rhs  `thenUs` \ (usg, rhs') ->
 724                         returnUs (usg, (bndr,rhs'))
 725
 726 scBind env (NonRec bndr rhs)
 727   = scExpr env rhs      `thenUs` \ (usg, rhs') ->
 728     returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
 729
 730 ----------------------
 731 varUsage env v use
 732   | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
 733                                                 occs = unitVarEnv v use }
 734   | otherwise                           = nullUsage
 735 \end{code}
 736
 737
 738 %************************************************************************
 739 %*                                                                      *
 740 \subsection{The specialiser}
 741 %*                                                                      *
 742 %************************************************************************
 743
 744 \begin{code}
 745 specialise :: ScEnv
 746            -> Id                        -- Functionn
 747            -> [CoreBndr] -> CoreExpr    -- Its RHS
 748            -> ScUsage                   -- Info on usage
 749            -> UniqSM ([CoreRule],       -- Rules
 750                       [(Id,CoreExpr)])  -- Bindings
 751
 752 specialise env fn bndrs body body_usg
 753   = do  { let (_, bndr_occs) = lookupOccs body_usg bndrs
 754
 755         ; mb_calls <- mapM (callToPats (scope env) bndr_occs)
 756                            (lookupVarEnv (calls body_usg) fn `orElse` [])
 757
 758         ; let good_calls :: [([Var], [CoreArg])]
 759               good_calls = catMaybes mb_calls
 760               in_scope = mkInScopeSet $ unionVarSets $
 761                          [ exprsFreeVars pats `delVarSetList` vs
 762                          | (vs,pats) <- good_calls ]
 763               uniq_calls = nubBy (same_call in_scope) good_calls
 764     in
 765     mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
 766                   (uniq_calls `zip` [1..]) }
 767   where
 768         -- Two calls are the same if they match both ways
 769     same_call in_scope (vs1,as1)(vs2,as2)
 770          =  isJust (matchN in_scope vs1 as1 as2)
 771          && isJust (matchN in_scope vs2 as2 as1)
 772
 773 callToPats :: InScopeEnv -> [ArgOcc] -> Call
 774            -> UniqSM (Maybe ([Var], [CoreExpr]))
 775         -- The VarSet is the variables to quantify over in the rule
 776         -- The [CoreExpr] are the argument patterns for the rule
 777 callToPats in_scope bndr_occs (con_env, args)
 778   | length args < length bndr_occs      -- Check saturated
 779   = return Nothing
 780   | otherwise
 781   = do  { prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
 782         ; let (good_pats, pats) = unzip prs
 783               pat_fvs = varSetElems (exprsFreeVars pats)
 784               qvars   = filter (not . (`elemVarEnv` in_scope)) pat_fvs
 785                 -- Quantify over variables that are not in sccpe
 786                 -- See Note [Shadowing] at the top
 787
 788         ; if or good_pats
 789           then return (Just (qvars, pats))
 790           else return Nothing }
 791
 792 ---------------------
 793 spec_one :: ScEnv
 794          -> Id                                  -- Function
 795          -> CoreExpr                            -- Rhs of the original function
 796          -> (([Var], [CoreArg]), Int)
 797          -> UniqSM (CoreRule, (Id,CoreExpr))    -- Rule and binding
 798
 799 -- spec_one creates a specialised copy of the function, together
 800 -- with a rule for using it.  I'm very proud of how short this
 801 -- function is, considering what it does :-).
 802
 803 {-
 804   Example
 805
 806      In-scope: a, x::a
 807      f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
 808           [c::*, v::(b,c) are presumably bound by the (...) part]
 809   ==>
 810      f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
 811                   (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
 812
 813      RULE:  forall b::* c::*,           -- Note, *not* forall a, x
 814                    v::(b,c),
 815                    hw::[(a,(b,c))] .
 816
 817             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
 818 -}
 819
 820 spec_one env fn rhs ((vars_to_bind, pats), rule_number)
 821   = getUniqueUs                 `thenUs` \ spec_uniq ->
 822     let
 823         fn_name      = idName fn
 824         fn_loc       = nameSrcLoc fn_name
 825         spec_occ     = mkSpecOcc (nameOccName fn_name)
 826
 827                 -- Put the type variables first; the type of a term
 828                 -- variable may mention a type variable
 829         (tvs, ids)   = partition isTyVar vars_to_bind
 830         bndrs        = tvs ++ ids
 831         spec_body    = mkApps rhs pats
 832         body_ty      = exprType spec_body
 833
 834         (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
 835                 -- Usual w/w hack to avoid generating
 836                 -- a spec_rhs of unlifted type and no args
 837
 838         rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
 839         spec_rhs  = mkLams spec_lam_args spec_body
 840         spec_id   = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
 841         rule_rhs  = mkVarApps (Var spec_id) spec_call_args
 842         rule      = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
 843     in
 844     returnUs (rule, (spec_id, spec_rhs))
 845
 846 -- In which phase should the specialise-constructor rules be active?
 847 -- Originally I made them always-active, but Manuel found that
 848 -- this defeated some clever user-written rules.  So Plan B
 849 -- is to make them active only in Phase 0; after all, currently,
 850 -- the specConstr transformation is only run after the simplifier
 851 -- has reached Phase 0.  In general one would want it to be
 852 -- flag-controllable, but for now I'm leaving it baked in
 853 --                                      [SLPJ Oct 01]
 854 specConstrActivation :: Activation
 855 specConstrActivation = ActiveAfter 0    -- Baked in; see comments above
 856 \end{code}
 857
 858 %************************************************************************
 859 %*                                                                      *
 860 \subsection{Argument analysis}
 861 %*                                                                      *
 862 %************************************************************************
 863
 864 This code deals with analysing call-site arguments to see whether
 865 they are constructor applications.
 866
 867
 868 \begin{code}
 869     -- argToPat takes an actual argument, and returns an abstracted
 870     -- version, consisting of just the "constructor skeleton" of the
 871     -- argument, with non-constructor sub-expression replaced by new
 872     -- placeholder variables.  For example:
 873     --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
 874
 875 argToPat :: InScopeEnv                  -- What's in scope at the fn defn site
 876          -> ConstrEnv                   -- ConstrEnv at the call site
 877          -> CoreArg                     -- A call arg (or component thereof)
 878          -> ArgOcc
 879          -> UniqSM (Bool, CoreArg)
 880 -- Returns (interesting, pat),
 881 -- where pat is the pattern derived from the argument
 882 --            intersting=True if the pattern is non-trivial (not a variable or type)
 883 -- E.g.         x:xs         --> (True, x:xs)
 884 --              f xs         --> (False, w)        where w is a fresh wildcard
 885 --              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
 886 --              \x. x+y      --> (True, \x. x+y)
 887 --              lvl7         --> (True, lvl7)      if lvl7 is bound
 888 --                                                 somewhere further out
 889
 890 argToPat in_scope con_env arg@(Type ty) arg_occ
 891   = return (False, arg)
 892
 893 argToPat in_scope con_env (Var v) arg_occ
 894   | not (isLocalId v) || v `elemVarEnv` in_scope
 895   =     -- The recursive call passes a variable that
 896         -- is in scope at the function definition site
 897         -- It's worth specialising on this if
 898         --      (a) it's used in an interesting way in the body
 899         --      (b) we know what its value is
 900     if    (case arg_occ of { UnkOcc -> False; other -> True })  -- (a)
 901        && isValueUnfolding (idUnfolding v)                      -- (b)
 902     then return (True, Var v)
 903     else wildCardPat (idType v)
 904
 905 argToPat in_scope con_env arg arg_occ
 906   | is_value_lam arg
 907   = return (True, arg)
 908   where
 909     is_value_lam (Lam v e)      -- Spot a value lambda, even if
 910         | isId v = True         -- it is inside a type lambda
 911         | otherwise = is_value_lam e
 912     is_value_lam other = False
 913
 914 argToPat in_scope con_env arg arg_occ
 915   | Just (CV dc args) <- is_con_app_maybe con_env arg
 916   , case arg_occ of
 917         ScrutOcc _ -> True              -- Used only by case scrutinee
 918         BothOcc    -> case arg of       -- Used by case scrut
 919                         App {} -> True  -- ...and elsewhere...
 920                         other  -> False
 921         other      -> False     -- No point; the arg is not decomposed
 922   = do  { args' <- argsToPats in_scope con_env (args `zip` conArgOccs arg_occ dc)
 923         ; return (True, mk_con_app dc (map snd args')) }
 924
 925 argToPat in_scope con_env (Var v) arg_occ
 926   =     -- A variable bound inside the function.
 927         -- Don't make a wild-card, because we may usefully share
 928         --      e.g.  f a = let x = ... in f (x,x)
 929         -- NB: this case follows the lambda and con-app cases!!
 930     return (False, Var v)
 931
 932 -- The default case: make a wild-card
 933 argToPat in_scope con_env arg arg_occ = wildCardPat (exprType arg)
 934
 935 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
 936 wildCardPat ty = do { uniq <- getUniqueUs
 937                     ; let id = mkSysLocal FSLIT("sc") uniq ty
 938                     ; return (False, Var id) }
 939
 940 argsToPats :: InScopeEnv -> ConstrEnv
 941            -> [(CoreArg, ArgOcc)]
 942            -> UniqSM [(Bool, CoreArg)]
 943 argsToPats in_scope con_env args
 944   = mapUs do_one args
 945   where
 946     do_one (arg,occ) = argToPat in_scope con_env arg occ
 947 \end{code}
 948
 949
 950 \begin{code}
 951 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
 952 is_con_app_maybe env (Var v)
 953   = case lookupVarEnv env v of
 954         Just stuff -> Just stuff
 955                 -- You might think we could look in the idUnfolding here
 956                 -- but that doesn't take account of which branch of a
 957                 -- case we are in, which is the whole point
 958
 959         Nothing | isCheapUnfolding unf
 960                 -> is_con_app_maybe env (unfoldingTemplate unf)
 961                 where
 962                   unf = idUnfolding v
 963                 -- However we do want to consult the unfolding
 964                 -- as well, for let-bound constructors!
 965
 966         other  -> Nothing
 967
 968 is_con_app_maybe env (Lit lit)
 969   = Just (CV (LitAlt lit) [])
 970
 971 is_con_app_maybe env expr
 972   = case collectArgs expr of
 973         (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
 974                           args `lengthAtLeast` dataConRepArity con
 975                 -- Might be > because the arity excludes type args
 976                         -> Just (CV (DataAlt con) args)
 977
 978         other -> Nothing
 979
 980 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
 981 mk_con_app (LitAlt lit)  []   = Lit lit
 982 mk_con_app (DataAlt con) args = mkConApp con args
 983 \end{code}