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