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