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