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