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, tcEqExpr, 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 )
  22 import Type             ( tyConAppArgs, tyVarsOfTypes )
  23 import Unify            ( coreRefineTys )
  24 import Id               ( Id, idName, idType, isDataConWorkId_maybe,
  25                           mkUserLocal, mkSysLocal, idUnfolding )
  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 )
  36 import Util             ( mapAccumL, lengthAtLeast, notNull )
  37 import List             ( nubBy, partition )
  38 import UniqSupply
  39 import Outputable
  40 import FastString
  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.  However we don't want to do that if the boxed version
  97 of n is needed (else we'd avoid the eval but pay more for re-boxing n).
  98 So in this case we want that the *only* uses of n are in case statements.
  99
 100
 101 Note [Good arguments]
 102 ~~~~~~~~~~~~~~~~~~~~~
 103 So we look for
 104
 105 * A self-recursive function.  Ignore mutual recursion for now,
 106   because it's less common, and the code is simpler for self-recursion.
 107
 108 * EITHER
 109
 110    a) At a recursive call, one or more parameters is an explicit
 111       constructor application
 112         AND
 113       That same parameter is scrutinised by a case somewhere in
 114       the RHS of the function
 115
 116   OR
 117
 118     b) At a recursive call, one or more parameters has an unfolding
 119        that is an explicit constructor application
 120         AND
 121       That same parameter is scrutinised by a case somewhere in
 122       the RHS of the function
 123         AND
 124       Those are the only uses of the parameter
 125
 126
 127 What to abstract over
 128 ~~~~~~~~~~~~~~~~~~~~~
 129 There's a bit of a complication with type arguments.  If the call
 130 site looks like
 131
 132         f p = ...f ((:) [a] x xs)...
 133
 134 then our specialised function look like
 135
 136         f_spec x xs = let p = (:) [a] x xs in ....as before....
 137
 138 This only makes sense if either
 139   a) the type variable 'a' is in scope at the top of f, or
 140   b) the type variable 'a' is an argument to f (and hence fs)
 141
 142 Actually, (a) may hold for value arguments too, in which case
 143 we may not want to pass them.  Supose 'x' is in scope at f's
 144 defn, but xs is not.  Then we'd like
 145
 146         f_spec xs = let p = (:) [a] x xs in ....as before....
 147
 148 Similarly (b) may hold too.  If x is already an argument at the
 149 call, no need to pass it again.
 150
 151 Finally, if 'a' is not in scope at the call site, we could abstract
 152 it as we do the term variables:
 153
 154         f_spec a x xs = let p = (:) [a] x xs in ...as before...
 155
 156 So the grand plan is:
 157
 158         * abstract the call site to a constructor-only pattern
 159           e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)
 160
 161         * Find the free variables of the abstracted pattern
 162
 163         * Pass these variables, less any that are in scope at
 164           the fn defn.  But see Note [Shadowing] below.
 165
 166
 167 NOTICE that we only abstract over variables that are not in scope,
 168 so we're in no danger of shadowing variables used in "higher up"
 169 in f_spec's RHS.
 170
 171
 172 Note [Shadowing]
 173 ~~~~~~~~~~~~~~~~
 174 In this pass we gather up usage information that may mention variables
 175 that are bound between the usage site and the definition site; or (more
 176 seriously) may be bound to something different at the definition site.
 177 For example:
 178
 179         f x = letrec g y v = let x = ...
 180                              in ...(g (a,b) x)...
 181
 182 Since 'x' is in scope at the call site, we may make a rewrite rule that
 183 looks like
 184         RULE forall a,b. g (a,b) x = ...
 185 But this rule will never match, because it's really a different 'x' at
 186 the call site -- and that difference will be manifest by the time the
 187 simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*
 188 no-shadowing, so perhaps it may not be distinct?]
 189
 190 Anyway, the rule isn't actually wrong, it's just not useful.  One possibility
 191 is to run deShadowBinds before running SpecConstr, but instead we run the
 192 simplifier.  That gives the simplest possible program for SpecConstr to
 193 chew on; and it virtually guarantees no shadowing.
 194
 195
 196 %************************************************************************
 197 %*                                                                      *
 198 \subsection{Top level wrapper stuff}
 199 %*                                                                      *
 200 %************************************************************************
 201
 202 \begin{code}
 203 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
 204 specConstrProgram dflags us binds
 205   = do
 206         showPass dflags "SpecConstr"
 207
 208         let (binds', _) = initUs us (go emptyScEnv binds)
 209
 210         endPass dflags "SpecConstr" Opt_D_dump_spec binds'
 211
 212         dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
 213                   (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
 214
 215         return binds'
 216   where
 217     go env []           = returnUs []
 218     go env (bind:binds) = scBind env bind       `thenUs` \ (env', _, bind') ->
 219                           go env' binds         `thenUs` \ binds' ->
 220                           returnUs (bind' : binds')
 221 \end{code}
 222
 223
 224 %************************************************************************
 225 %*                                                                      *
 226 \subsection{Environment: goes downwards}
 227 %*                                                                      *
 228 %************************************************************************
 229
 230 \begin{code}
 231 data ScEnv = SCE { scope :: VarEnv HowBound,
 232                         -- Binds all non-top-level variables in scope
 233
 234                    cons  :: ConstrEnv
 235              }
 236
 237 type ConstrEnv = IdEnv ConValue
 238 data ConValue  = CV AltCon [CoreArg]
 239         -- Variables known to be bound to a constructor
 240         -- in a particular case alternative
 241
 242
 243 instance Outputable ConValue where
 244    ppr (CV con args) = ppr con <+> interpp'SP args
 245
 246 refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv
 247 -- The substitution is a type substitution only
 248 refineConstrEnv subst env = mapVarEnv refine_con_value env
 249   where
 250     refine_con_value (CV con args) = CV con (map (substExpr subst) args)
 251
 252 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
 253
 254 data HowBound = RecFun          -- These are the recursive functions for which
 255                                 -- we seek interesting call patterns
 256
 257               | RecArg          -- These are those functions' arguments; we are
 258                                 -- interested to see if those arguments are scrutinised
 259
 260               | Other           -- We track all others so we know what's in scope
 261                                 -- This is used in spec_one to check what needs to be
 262                                 -- passed as a parameter and what is in scope at the
 263                                 -- function definition site
 264
 265 instance Outputable HowBound where
 266   ppr RecFun = text "RecFun"
 267   ppr RecArg = text "RecArg"
 268   ppr Other = text "Other"
 269
 270 lookupScopeEnv env v = lookupVarEnv (scope env) v
 271
 272 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
 273 extendBndr  env bndr  = env { scope = extendVarEnv (scope env) bndr Other }
 274
 275     -- When we encounter
 276     --  case scrut of b
 277     --      C x y -> ...
 278     -- we want to bind b, and perhaps scrut too, to (C x y)
 279 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
 280 extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
 281   = extendBndrs env (case_bndr : alt_bndrs)
 282
 283 extendCaseBndrs env case_bndr scrut con@(LitAlt lit) alt_bndrs
 284   = ASSERT( null alt_bndrs ) extendAlt env case_bndr scrut (CV con []) []
 285
 286 extendCaseBndrs env case_bndr scrut con@(DataAlt data_con) alt_bndrs
 287   | isVanillaDataCon data_con
 288   = extendAlt env case_bndr scrut (CV con vanilla_args) alt_bndrs
 289
 290   | otherwise   -- GADT
 291   = extendAlt env1 case_bndr scrut (CV con gadt_args) alt_bndrs
 292   where
 293     vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
 294                    map varToCoreExpr alt_bndrs
 295
 296     gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
 297         -- This call generates some bogus warnings from substExpr,
 298         -- because it's inconvenient to put all the Ids in scope
 299         -- Will be fixed when we move to FC
 300
 301     (alt_tvs, _) = span isTyVar alt_bndrs
 302     Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
 303     subst = mkSubst in_scope tv_subst emptyVarEnv       -- No Id substitition
 304     in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
 305
 306     env1 | is_local  = env
 307          | otherwise = env { cons = refineConstrEnv subst (cons env) }
 308
 309
 310
 311 extendAlt :: ScEnv -> Id -> CoreExpr -> ConValue -> [Var] -> ScEnv
 312 extendAlt env case_bndr scrut val alt_bndrs
 313   = let
 314        env1 = SCE { scope = extendVarEnvList (scope env) [(b,Other) | b <- case_bndr : alt_bndrs],
 315                     cons  = extendVarEnv     (cons  env) case_bndr val }
 316     in
 317     case scrut of
 318         Var v ->   -- Bind the scrutinee in the ConstrEnv if it's a variable
 319                    -- Also forget if the scrutinee is a RecArg, because we're
 320                    -- now in the branch of a case, and we don't want to
 321                    -- record a non-scrutinee use of v if we have
 322                    --   case v of { (a,b) -> ...(f v)... }
 323                  SCE { scope = extendVarEnv (scope env1) v Other,
 324                        cons  = extendVarEnv (cons env1)  v val }
 325         other -> env1
 326
 327     -- When we encounter a recursive function binding
 328     --  f = \x y -> ...
 329     -- we want to extend the scope env with bindings
 330     -- that record that f is a RecFn and x,y are RecArgs
 331 extendRecBndr env fn bndrs
 332   =  env { scope = scope env `extendVarEnvList`
 333                    ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
 334 \end{code}
 335
 336
 337 %************************************************************************
 338 %*                                                                      *
 339 \subsection{Usage information: flows upwards}
 340 %*                                                                      *
 341 %************************************************************************
 342
 343 \begin{code}
 344 data ScUsage
 345    = SCU {
 346         calls :: !(IdEnv ([Call])),     -- Calls
 347                                         -- The functions are a subset of the
 348                                         --      RecFuns in the ScEnv
 349
 350         occs :: !(IdEnv ArgOcc)         -- Information on argument occurrences
 351      }                                  -- The variables are a subset of the
 352                                         --      RecArg in the ScEnv
 353
 354 type Call = (ConstrEnv, [CoreArg])
 355         -- The arguments of the call, together with the
 356         -- env giving the constructor bindings at the call site
 357
 358 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
 359
 360 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
 361                            occs  = plusVarEnv_C combineOcc (occs u1) (occs u2) }
 362
 363 combineUsages [] = nullUsage
 364 combineUsages us = foldr1 combineUsage us
 365
 366 data ArgOcc = CaseScrut
 367             | OtherOcc
 368             | Both
 369
 370 instance Outputable ArgOcc where
 371   ppr CaseScrut = ptext SLIT("case-scrut")
 372   ppr OtherOcc  = ptext SLIT("other-occ")
 373   ppr Both      = ptext SLIT("case-scrut and other")
 374
 375 combineOcc CaseScrut CaseScrut = CaseScrut
 376 combineOcc OtherOcc  OtherOcc  = OtherOcc
 377 combineOcc _         _         = Both
 378 \end{code}
 379
 380
 381 %************************************************************************
 382 %*                                                                      *
 383 \subsection{The main recursive function}
 384 %*                                                                      *
 385 %************************************************************************
 386
 387 The main recursive function gathers up usage information, and
 388 creates specialised versions of functions.
 389
 390 \begin{code}
 391 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
 392         -- The unique supply is needed when we invent
 393         -- a new name for the specialised function and its args
 394
 395 scExpr env e@(Type t) = returnUs (nullUsage, e)
 396 scExpr env e@(Lit l)  = returnUs (nullUsage, e)
 397 scExpr env e@(Var v)  = returnUs (varUsage env v OtherOcc, e)
 398 scExpr env (Note n e) = scExpr env e    `thenUs` \ (usg,e') ->
 399                         returnUs (usg, Note n e')
 400 scExpr env (Lam b e)  = scExpr (extendBndr env b) e     `thenUs` \ (usg,e') ->
 401                         returnUs (usg, Lam b e')
 402
 403 scExpr env (Case scrut b ty alts)
 404   = sc_scrut scrut              `thenUs` \ (scrut_usg, scrut') ->
 405     mapAndUnzipUs sc_alt alts   `thenUs` \ (alts_usgs, alts') ->
 406     returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
 407               Case scrut' b ty alts')
 408   where
 409     sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
 410     sc_scrut e         = scExpr env e
 411
 412     sc_alt (con,bs,rhs) = scExpr env1 rhs       `thenUs` \ (usg,rhs') ->
 413                           returnUs (usg, (con,bs,rhs'))
 414                         where
 415                           env1 = extendCaseBndrs env b scrut con bs
 416
 417 scExpr env (Let bind body)
 418   = scBind env bind     `thenUs` \ (env', bind_usg, bind') ->
 419     scExpr env' body    `thenUs` \ (body_usg, body') ->
 420     returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
 421
 422 scExpr env e@(App _ _)
 423   = let
 424         (fn, args) = collectArgs e
 425     in
 426     mapAndUnzipUs (scExpr env) (fn:args)        `thenUs` \ (usgs, (fn':args')) ->
 427         -- Process the function too.   It's almost always a variable,
 428         -- but not always.  In particular, if this pass follows float-in,
 429         -- which it may, we can get
 430         --      (let f = ...f... in f) arg1 arg2
 431     let
 432         call_usg = case fn of
 433                         Var f | Just RecFun <- lookupScopeEnv env f
 434                               -> SCU { calls = unitVarEnv f [(cons env, args)],
 435                                        occs  = emptyVarEnv }
 436                         other -> nullUsage
 437     in
 438     returnUs (combineUsages usgs `combineUsage` call_usg, mkApps fn' args')
 439
 440
 441 ----------------------
 442 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
 443 scBind env (Rec [(fn,rhs)])
 444   | notNull val_bndrs
 445   = scExpr env_fn_body body             `thenUs` \ (usg, body') ->
 446     specialise env fn bndrs body' usg   `thenUs` \ (rules, spec_prs) ->
 447         -- Note body': the specialised copies should be based on the
 448         --             optimised version of the body, in case there were
 449         --             nested functions inside.
 450     let
 451         SCU { calls = calls, occs = occs } = usg
 452     in
 453     returnUs (extendBndr env fn,        -- For the body of the letrec, just
 454                                         -- extend the env with Other to record
 455                                         -- that it's in scope; no funny RecFun business
 456               SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
 457               Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
 458   where
 459     (bndrs,body) = collectBinders rhs
 460     val_bndrs    = filter isId bndrs
 461     env_fn_body  = extendRecBndr env fn bndrs
 462
 463 scBind env (Rec prs)
 464   = mapAndUnzipUs do_one prs    `thenUs` \ (usgs, prs') ->
 465     returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
 466   where
 467     do_one (bndr,rhs) = scExpr env rhs  `thenUs` \ (usg, rhs') ->
 468                         returnUs (usg, (bndr,rhs'))
 469
 470 scBind env (NonRec bndr rhs)
 471   = scExpr env rhs      `thenUs` \ (usg, rhs') ->
 472     returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
 473
 474 ----------------------
 475 varUsage env v use
 476   | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
 477                                                 occs = unitVarEnv v use }
 478   | otherwise                           = nullUsage
 479 \end{code}
 480
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsection{The specialiser}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 \begin{code}
 489 specialise :: ScEnv
 490            -> Id                        -- Functionn
 491            -> [CoreBndr] -> CoreExpr    -- Its RHS
 492            -> ScUsage                   -- Info on usage
 493            -> UniqSM ([CoreRule],       -- Rules
 494                       [(Id,CoreExpr)])  -- Bindings
 495
 496 specialise env fn bndrs body (SCU {calls=calls, occs=occs})
 497   = getUs               `thenUs` \ us ->
 498     let
 499         all_calls = lookupVarEnv calls fn `orElse` []
 500
 501         good_calls :: [[CoreArg]]
 502         good_calls = [ pats
 503                      | (con_env, call_args) <- all_calls,
 504                        call_args `lengthAtLeast` n_bndrs,           -- App is saturated
 505                        let call = bndrs `zip` call_args,
 506                        any (good_arg con_env occs) call,    -- At least one arg is a constr app
 507                        let (_, pats) = argsToPats con_env us call_args
 508                      ]
 509     in
 510     mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
 511                   (nubBy same_call good_calls `zip` [1..])
 512   where
 513     n_bndrs  = length bndrs
 514     same_call as1 as2 = and (zipWith tcEqExpr as1 as2)
 515
 516 ---------------------
 517 good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
 518 -- See Note [Good arguments] above
 519 good_arg con_env arg_occs (bndr, arg)
 520   = case is_con_app_maybe con_env arg of
 521         Just _ ->  bndr_usg_ok arg_occs bndr arg
 522         other   -> False
 523
 524 bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
 525 bndr_usg_ok arg_occs bndr arg
 526   = case lookupVarEnv arg_occs bndr of
 527         Just CaseScrut -> True                  -- Used only by case scrutiny
 528         Just Both      -> case arg of           -- Used by case and elsewhere
 529                             App _ _ -> True     -- so the arg should be an explicit con app
 530                             other   -> False
 531         other -> False                          -- Not used, or used wonkily
 532
 533
 534 ---------------------
 535 spec_one :: ScEnv
 536          -> Id                                  -- Function
 537          -> CoreExpr                            -- Rhs of the original function
 538          -> ([CoreArg], Int)
 539          -> UniqSM (CoreRule, (Id,CoreExpr))    -- Rule and binding
 540
 541 -- spec_one creates a specialised copy of the function, together
 542 -- with a rule for using it.  I'm very proud of how short this
 543 -- function is, considering what it does :-).
 544
 545 {-
 546   Example
 547
 548      In-scope: a, x::a
 549      f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
 550           [c::*, v::(b,c) are presumably bound by the (...) part]
 551   ==>
 552      f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
 553                   (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
 554
 555      RULE:  forall b::* c::*,           -- Note, *not* forall a, x
 556                    v::(b,c),
 557                    hw::[(a,(b,c))] .
 558
 559             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
 560 -}
 561
 562 spec_one env fn rhs (pats, rule_number)
 563   = getUniqueUs                 `thenUs` \ spec_uniq ->
 564     let
 565         fn_name      = idName fn
 566         fn_loc       = nameSrcLoc fn_name
 567         spec_occ     = mkSpecOcc (nameOccName fn_name)
 568         pat_fvs      = varSetElems (exprsFreeVars pats)
 569         vars_to_bind = filter not_avail pat_fvs
 570                 -- See Note [Shadowing] at the top
 571
 572         not_avail v  = not (v `elemVarEnv` scope env)
 573                 -- Put the type variables first; the type of a term
 574                 -- variable may mention a type variable
 575         (tvs, ids)   = partition isTyVar vars_to_bind
 576         bndrs        = tvs ++ ids
 577         spec_body    = mkApps rhs pats
 578         body_ty      = exprType spec_body
 579
 580         (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
 581                 -- Usual w/w hack to avoid generating
 582                 -- a spec_rhs of unlifted type and no args
 583
 584         rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
 585         spec_rhs  = mkLams spec_lam_args spec_body
 586         spec_id   = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
 587         rule_rhs  = mkVarApps (Var spec_id) spec_call_args
 588         rule      = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
 589     in
 590     returnUs (rule, (spec_id, spec_rhs))
 591
 592 -- In which phase should the specialise-constructor rules be active?
 593 -- Originally I made them always-active, but Manuel found that
 594 -- this defeated some clever user-written rules.  So Plan B
 595 -- is to make them active only in Phase 0; after all, currently,
 596 -- the specConstr transformation is only run after the simplifier
 597 -- has reached Phase 0.  In general one would want it to be
 598 -- flag-controllable, but for now I'm leaving it baked in
 599 --                                      [SLPJ Oct 01]
 600 specConstrActivation :: Activation
 601 specConstrActivation = ActiveAfter 0    -- Baked in; see comments above
 602 \end{code}
 603
 604 %************************************************************************
 605 %*                                                                      *
 606 \subsection{Argument analysis}
 607 %*                                                                      *
 608 %************************************************************************
 609
 610 This code deals with analysing call-site arguments to see whether
 611 they are constructor applications.
 612
 613 \begin{code}
 614     -- argToPat takes an actual argument, and returns an abstracted
 615     -- version, consisting of just the "constructor skeleton" of the
 616     -- argument, with non-constructor sub-expression replaced by new
 617     -- placeholder variables.  For example:
 618     --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
 619
 620 argToPat   :: ConstrEnv -> UniqSupply -> CoreArg -> (UniqSupply, CoreExpr)
 621 argToPat env us (Type ty)
 622   = (us, Type ty)
 623
 624 argToPat env us arg
 625   | Just (CV dc args) <- is_con_app_maybe env arg
 626   = let
 627         (us',args') = argsToPats env us args
 628     in
 629     (us', mk_con_app dc args')
 630
 631 argToPat env us (Var v) -- Don't uniqify existing vars,
 632   = (us, Var v)         -- so that we can spot when we pass them twice
 633
 634 argToPat env us arg
 635   = (us1, Var (mkSysLocal FSLIT("sc") (uniqFromSupply us2) (exprType arg)))
 636   where
 637     (us1,us2) = splitUniqSupply us
 638
 639 argsToPats :: ConstrEnv -> UniqSupply -> [CoreArg] -> (UniqSupply, [CoreExpr])
 640 argsToPats env us args = mapAccumL (argToPat env) us args
 641 \end{code}
 642
 643
 644 \begin{code}
 645 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
 646 is_con_app_maybe env (Var v)
 647   = case lookupVarEnv env v of
 648         Just stuff -> Just stuff
 649                 -- You might think we could look in the idUnfolding here
 650                 -- but that doesn't take account of which branch of a
 651                 -- case we are in, which is the whole point
 652
 653         Nothing | isCheapUnfolding unf
 654                 -> is_con_app_maybe env (unfoldingTemplate unf)
 655                 where
 656                   unf = idUnfolding v
 657                 -- However we do want to consult the unfolding as well,
 658                 -- for let-bound constructors!
 659
 660         other  -> Nothing
 661
 662 is_con_app_maybe env (Lit lit)
 663   = Just (CV (LitAlt lit) [])
 664
 665 is_con_app_maybe env expr
 666   = case collectArgs expr of
 667         (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
 668                           args `lengthAtLeast` dataConRepArity con
 669                 -- Might be > because the arity excludes type args
 670                         -> Just (CV (DataAlt con) args)
 671
 672         other -> Nothing
 673
 674 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
 675 mk_con_app (LitAlt lit)  []   = Lit lit
 676 mk_con_app (DataAlt con) args = mkConApp con args
 677 \end{code}