compiler/coreSyn/CorePrep.lhs

   1 %
   2 % (c) The University of Glasgow, 1994-2006
   3 %
   4
   5 Core pass to saturate constructors and PrimOps
   6
   7 \begin{code}
   8 module CorePrep (
   9       corePrepPgm, corePrepExpr
  10   ) where
  11
  12 #include "HsVersions.h"
  13
  14 import CoreUtils hiding (exprIsTrivial)
  15 import CoreFVs
  16 import CoreLint
  17 import CoreSyn
  18 import Type
  19 import Coercion
  20 import TyCon
  21 import NewDemand
  22 import Var
  23 import VarSet
  24 import VarEnv
  25 import Id
  26 import DataCon
  27 import PrimOp
  28 import BasicTypes
  29 import UniqSupply
  30 import Maybes
  31 import OrdList
  32 import ErrUtils
  33 import DynFlags
  34 import Util
  35 import Outputable
  36 \end{code}
  37
  38 -- ---------------------------------------------------------------------------
  39 -- Overview
  40 -- ---------------------------------------------------------------------------
  41
  42 The goal of this pass is to prepare for code generation.
  43
  44 1.  Saturate constructor and primop applications.
  45
  46 2.  Convert to A-normal form; that is, function arguments
  47     are always variables.
  48
  49     * Use case for strict arguments:
  50         f E ==> case E of x -> f x
  51         (where f is strict)
  52
  53     * Use let for non-trivial lazy arguments
  54         f E ==> let x = E in f x
  55         (were f is lazy and x is non-trivial)
  56
  57 3.  Similarly, convert any unboxed lets into cases.
  58     [I'm experimenting with leaving 'ok-for-speculation'
  59      rhss in let-form right up to this point.]
  60
  61 4.  Ensure that lambdas only occur as the RHS of a binding
  62     (The code generator can't deal with anything else.)
  63
  64 5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
  65
  66 6.  Clone all local Ids.
  67     This means that all such Ids are unique, rather than the
  68     weaker guarantee of no clashes which the simplifier provides.
  69     And that is what the code generator needs.
  70
  71     We don't clone TyVars. The code gen doesn't need that,
  72     and doing so would be tiresome because then we'd need
  73     to substitute in types.
  74
  75
  76 7.  Give each dynamic CCall occurrence a fresh unique; this is
  77     rather like the cloning step above.
  78
  79 8.  Inject bindings for the "implicit" Ids:
  80         * Constructor wrappers
  81         * Constructor workers
  82         * Record selectors
  83     We want curried definitions for all of these in case they
  84     aren't inlined by some caller.
  85
  86 This is all done modulo type applications and abstractions, so that
  87 when type erasure is done for conversion to STG, we don't end up with
  88 any trivial or useless bindings.
  89
  90
  91
  92 -- -----------------------------------------------------------------------------
  93 -- Top level stuff
  94 -- -----------------------------------------------------------------------------
  95
  96 \begin{code}
  97 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
  98 corePrepPgm dflags binds data_tycons
  99   = do  showPass dflags "CorePrep"
 100         us <- mkSplitUniqSupply 's'
 101
 102         let implicit_binds = mkDataConWorkers data_tycons
 103                 -- NB: we must feed mkImplicitBinds through corePrep too
 104                 -- so that they are suitably cloned and eta-expanded
 105
 106             binds_out = initUs_ us (
 107                           corePrepTopBinds binds        `thenUs` \ floats1 ->
 108                           corePrepTopBinds implicit_binds       `thenUs` \ floats2 ->
 109                           returnUs (deFloatTop (floats1 `appendFloats` floats2))
 110                         )
 111
 112         endPass dflags "CorePrep" Opt_D_dump_prep binds_out
 113         return binds_out
 114
 115 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 116 corePrepExpr dflags expr
 117   = do showPass dflags "CorePrep"
 118        us <- mkSplitUniqSupply 's'
 119        let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
 120        dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
 121                      (ppr new_expr)
 122        return new_expr
 123 \end{code}
 124
 125 -- -----------------------------------------------------------------------------
 126 -- Implicit bindings
 127 -- -----------------------------------------------------------------------------
 128
 129 Create any necessary "implicit" bindings for data con workers.  We
 130 create the rather strange (non-recursive!) binding
 131
 132         $wC = \x y -> $wC x y
 133
 134 i.e. a curried constructor that allocates.  This means that we can
 135 treat the worker for a constructor like any other function in the rest
 136 of the compiler.  The point here is that CoreToStg will generate a
 137 StgConApp for the RHS, rather than a call to the worker (which would
 138 give a loop).  As Lennart says: the ice is thin here, but it works.
 139
 140 Hmm.  Should we create bindings for dictionary constructors?  They are
 141 always fully applied, and the bindings are just there to support
 142 partial applications. But it's easier to let them through.
 143
 144 \begin{code}
 145 mkDataConWorkers data_tycons
 146   = [ NonRec id (Var id)        -- The ice is thin here, but it works
 147     | tycon <- data_tycons,     -- CorePrep will eta-expand it
 148       data_con <- tyConDataCons tycon,
 149       let id = dataConWorkId data_con ]
 150 \end{code}
 151
 152
 153 \begin{code}
 154 -- ---------------------------------------------------------------------------
 155 -- Dealing with bindings
 156 -- ---------------------------------------------------------------------------
 157
 158 data FloatingBind = FloatLet CoreBind
 159                   | FloatCase Id CoreExpr Bool
 160                         -- The bool indicates "ok-for-speculation"
 161
 162 data Floats = Floats OkToSpec (OrdList FloatingBind)
 163
 164 -- Can we float these binds out of the rhs of a let?  We cache this decision
 165 -- to avoid having to recompute it in a non-linear way when there are
 166 -- deeply nested lets.
 167 data OkToSpec
 168    = NotOkToSpec        -- definitely not
 169    | OkToSpec           -- yes
 170    | IfUnboxedOk        -- only if floating an unboxed binding is ok
 171
 172 emptyFloats :: Floats
 173 emptyFloats = Floats OkToSpec nilOL
 174
 175 addFloat :: Floats -> FloatingBind -> Floats
 176 addFloat (Floats ok_to_spec floats) new_float
 177   = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
 178   where
 179     check (FloatLet _)                = OkToSpec
 180     check (FloatCase _ _ ok_for_spec)
 181         | ok_for_spec  =  IfUnboxedOk
 182         | otherwise    =  NotOkToSpec
 183         -- The ok-for-speculation flag says that it's safe to
 184         -- float this Case out of a let, and thereby do it more eagerly
 185         -- We need the top-level flag because it's never ok to float
 186         -- an unboxed binding to the top level
 187
 188 unitFloat :: FloatingBind -> Floats
 189 unitFloat = addFloat emptyFloats
 190
 191 appendFloats :: Floats -> Floats -> Floats
 192 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
 193   = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
 194
 195 concatFloats :: [Floats] -> Floats
 196 concatFloats = foldr appendFloats emptyFloats
 197
 198 combine NotOkToSpec _ = NotOkToSpec
 199 combine _ NotOkToSpec = NotOkToSpec
 200 combine IfUnboxedOk _ = IfUnboxedOk
 201 combine _ IfUnboxedOk = IfUnboxedOk
 202 combine _ _           = OkToSpec
 203
 204 instance Outputable FloatingBind where
 205   ppr (FloatLet bind)        = text "FloatLet" <+> ppr bind
 206   ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
 207
 208 deFloatTop :: Floats -> [CoreBind]
 209 -- For top level only; we don't expect any FloatCases
 210 deFloatTop (Floats _ floats)
 211   = foldrOL get [] floats
 212   where
 213     get (FloatLet b) bs = b:bs
 214     get b            bs = pprPanic "corePrepPgm" (ppr b)
 215
 216 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
 217 allLazy top_lvl is_rec (Floats ok_to_spec _)
 218   = case ok_to_spec of
 219         OkToSpec    -> True
 220         NotOkToSpec -> False
 221         IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
 222
 223 -- ---------------------------------------------------------------------------
 224 --                      Bindings
 225 -- ---------------------------------------------------------------------------
 226
 227 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
 228 corePrepTopBinds binds
 229   = go emptyCorePrepEnv binds
 230   where
 231     go env []             = returnUs emptyFloats
 232     go env (bind : binds) = corePrepTopBind env bind    `thenUs` \ (env', bind') ->
 233                             go env' binds               `thenUs` \ binds' ->
 234                             returnUs (bind' `appendFloats` binds')
 235
 236 -- NB: we do need to float out of top-level bindings
 237 -- Consider     x = length [True,False]
 238 -- We want to get
 239 --              s1 = False : []
 240 --              s2 = True  : s1
 241 --              x  = length s2
 242
 243 -- We return a *list* of bindings, because we may start with
 244 --      x* = f (g y)
 245 -- where x is demanded, in which case we want to finish with
 246 --      a = g y
 247 --      x* = f a
 248 -- And then x will actually end up case-bound
 249 --
 250 -- What happens to the CafInfo on the floated bindings?  By
 251 -- default, all the CafInfos will be set to MayHaveCafRefs,
 252 -- which is safe.
 253 --
 254 -- This might be pessimistic, because eg. s1 & s2
 255 -- might not refer to any CAFs and the GC will end up doing
 256 -- more traversal than is necessary, but it's still better
 257 -- than not floating the bindings at all, because then
 258 -- the GC would have to traverse the structure in the heap
 259 -- instead.  Given this, we decided not to try to get
 260 -- the CafInfo on the floated bindings correct, because
 261 -- it looks difficult.
 262
 263 --------------------------------
 264 corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
 265 corePrepTopBind env (NonRec bndr rhs)
 266   = cloneBndr env bndr                                  `thenUs` \ (env', bndr') ->
 267     corePrepRhs TopLevel NonRecursive env (bndr, rhs)   `thenUs` \ (floats, rhs') ->
 268     returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
 269
 270 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
 271
 272 --------------------------------
 273 corePrepBind ::  CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
 274         -- This one is used for *local* bindings
 275 corePrepBind env (NonRec bndr rhs)
 276   = etaExpandRhs bndr rhs                               `thenUs` \ rhs1 ->
 277     corePrepExprFloat env rhs1                          `thenUs` \ (floats, rhs2) ->
 278     cloneBndr env bndr                                  `thenUs` \ (_, bndr') ->
 279     mkLocalNonRec bndr' (bdrDem bndr) floats rhs2       `thenUs` \ (floats', bndr'') ->
 280         -- We want bndr'' in the envt, because it records
 281         -- the evaluated-ness of the binder
 282     returnUs (extendCorePrepEnv env bndr bndr'', floats')
 283
 284 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
 285
 286 --------------------------------
 287 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
 288                  -> [(Id,CoreExpr)]     -- Recursive bindings
 289                  -> UniqSM (CorePrepEnv, Floats)
 290 -- Used for all recursive bindings, top level and otherwise
 291 corePrepRecPairs lvl env pairs
 292   = cloneBndrs env (map fst pairs)                              `thenUs` \ (env', bndrs') ->
 293     mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs        `thenUs` \ (floats_s, rhss') ->
 294     returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
 295   where
 296         -- Flatten all the floats, and the currrent
 297         -- group into a single giant Rec
 298     flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
 299
 300     get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
 301     get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
 302     get b                       prs2 = pprPanic "corePrepRecPairs" (ppr b)
 303
 304 --------------------------------
 305 corePrepRhs :: TopLevelFlag -> RecFlag
 306             -> CorePrepEnv -> (Id, CoreExpr)
 307             -> UniqSM (Floats, CoreExpr)
 308 -- Used for top-level bindings, and local recursive bindings
 309 corePrepRhs top_lvl is_rec env (bndr, rhs)
 310   = etaExpandRhs bndr rhs       `thenUs` \ rhs' ->
 311     corePrepExprFloat env rhs'  `thenUs` \ floats_w_rhs ->
 312     floatRhs top_lvl is_rec bndr floats_w_rhs
 313
 314
 315 -- ---------------------------------------------------------------------------
 316 -- Making arguments atomic (function args & constructor args)
 317 -- ---------------------------------------------------------------------------
 318
 319 -- This is where we arrange that a non-trivial argument is let-bound
 320 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
 321            -> UniqSM (Floats, CoreArg)
 322 corePrepArg env arg dem
 323   = corePrepExprFloat env arg           `thenUs` \ (floats, arg') ->
 324     if exprIsTrivial arg'
 325     then returnUs (floats, arg')
 326     else newVar (exprType arg')                 `thenUs` \ v ->
 327          mkLocalNonRec v dem floats arg'        `thenUs` \ (floats', v') ->
 328          returnUs (floats', Var v')
 329
 330 -- version that doesn't consider an scc annotation to be trivial.
 331 exprIsTrivial (Var v)                  = True
 332 exprIsTrivial (Type _)                 = True
 333 exprIsTrivial (Lit lit)                = True
 334 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 335 exprIsTrivial (Note (SCC _) e)         = False
 336 exprIsTrivial (Note _ e)               = exprIsTrivial e
 337 exprIsTrivial (Cast e co)              = exprIsTrivial e
 338 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 339 exprIsTrivial other                    = False
 340
 341 -- ---------------------------------------------------------------------------
 342 -- Dealing with expressions
 343 -- ---------------------------------------------------------------------------
 344
 345 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
 346 corePrepAnExpr env expr
 347   = corePrepExprFloat env expr          `thenUs` \ (floats, expr) ->
 348     mkBinds floats expr
 349
 350
 351 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
 352 -- If
 353 --      e  ===>  (bs, e')
 354 -- then
 355 --      e = let bs in e'        (semantically, that is!)
 356 --
 357 -- For example
 358 --      f (g x)   ===>   ([v = g x], f v)
 359
 360 corePrepExprFloat env (Var v)
 361   = fiddleCCall v                               `thenUs` \ v1 ->
 362     let
 363         v2 = lookupCorePrepEnv env v1
 364     in
 365     maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
 366
 367 corePrepExprFloat env expr@(Type _)
 368   = returnUs (emptyFloats, expr)
 369
 370 corePrepExprFloat env expr@(Lit lit)
 371   = returnUs (emptyFloats, expr)
 372
 373 corePrepExprFloat env (Let bind body)
 374   = corePrepBind env bind               `thenUs` \ (env', new_binds) ->
 375     corePrepExprFloat env' body         `thenUs` \ (floats, new_body) ->
 376     returnUs (new_binds `appendFloats` floats, new_body)
 377
 378 corePrepExprFloat env (Note n@(SCC _) expr)
 379   = corePrepAnExpr env expr             `thenUs` \ expr1 ->
 380     deLamFloat expr1                    `thenUs` \ (floats, expr2) ->
 381     returnUs (floats, Note n expr2)
 382
 383 corePrepExprFloat env (Note other_note expr)
 384   = corePrepExprFloat env expr          `thenUs` \ (floats, expr') ->
 385     returnUs (floats, Note other_note expr')
 386
 387 corePrepExprFloat env (Cast expr co)
 388   = corePrepExprFloat env expr          `thenUs` \ (floats, expr') ->
 389     returnUs (floats, Cast expr' co)
 390
 391 corePrepExprFloat env expr@(Lam _ _)
 392   = cloneBndrs env bndrs                `thenUs` \ (env', bndrs') ->
 393     corePrepAnExpr env' body            `thenUs` \ body' ->
 394     returnUs (emptyFloats, mkLams bndrs' body')
 395   where
 396     (bndrs,body) = collectBinders expr
 397
 398 corePrepExprFloat env (Case scrut bndr ty alts)
 399   = corePrepExprFloat env scrut         `thenUs` \ (floats1, scrut1) ->
 400     deLamFloat scrut1                   `thenUs` \ (floats2, scrut2) ->
 401     let
 402         bndr1 = bndr `setIdUnfolding` evaldUnfolding
 403         -- Record that the case binder is evaluated in the alternatives
 404     in
 405     cloneBndr env bndr1                 `thenUs` \ (env', bndr2) ->
 406     mapUs (sat_alt env') alts           `thenUs` \ alts' ->
 407     returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
 408   where
 409     sat_alt env (con, bs, rhs)
 410           = cloneBndrs env bs           `thenUs` \ (env2, bs') ->
 411             corePrepAnExpr env2 rhs     `thenUs` \ rhs1 ->
 412             deLam rhs1                  `thenUs` \ rhs2 ->
 413             returnUs (con, bs', rhs2)
 414
 415 corePrepExprFloat env expr@(App _ _)
 416   = collect_args expr 0  `thenUs` \ (app, (head,depth), ty, floats, ss) ->
 417     ASSERT(null ss)     -- make sure we used all the strictness info
 418
 419         -- Now deal with the function
 420     case head of
 421       Var fn_id -> maybeSaturate fn_id app depth floats ty
 422       _other    -> returnUs (floats, app)
 423
 424   where
 425
 426     -- Deconstruct and rebuild the application, floating any non-atomic
 427     -- arguments to the outside.  We collect the type of the expression,
 428     -- the head of the application, and the number of actual value arguments,
 429     -- all of which are used to possibly saturate this application if it
 430     -- has a constructor or primop at the head.
 431
 432     collect_args
 433         :: CoreExpr
 434         -> Int                            -- current app depth
 435         -> UniqSM (CoreExpr,              -- the rebuilt expression
 436                    (CoreExpr,Int),        -- the head of the application,
 437                                           -- and no. of args it was applied to
 438                    Type,                  -- type of the whole expr
 439                    Floats,                -- any floats we pulled out
 440                    [Demand])              -- remaining argument demands
 441
 442     collect_args (App fun arg@(Type arg_ty)) depth
 443         = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 444           returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 445
 446     collect_args (App fun arg) depth
 447         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 448           let
 449               (ss1, ss_rest)   = case ss of
 450                                    (ss1:ss_rest) -> (ss1,     ss_rest)
 451                                    []            -> (lazyDmd, [])
 452               (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
 453                                  splitFunTy_maybe fun_ty
 454           in
 455           corePrepArg env arg (mkDemTy ss1 arg_ty)      `thenUs` \ (fs, arg') ->
 456           returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
 457
 458     collect_args (Var v) depth
 459         = fiddleCCall v `thenUs` \ v1 ->
 460           let
 461                 v2 = lookupCorePrepEnv env v1
 462           in
 463           returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
 464         where
 465           stricts = case idNewStrictness v of
 466                         StrictSig (DmdType _ demands _)
 467                             | listLengthCmp demands depth /= GT -> demands
 468                                     -- length demands <= depth
 469                             | otherwise                         -> []
 470                 -- If depth < length demands, then we have too few args to
 471                 -- satisfy strictness  info so we have to  ignore all the
 472                 -- strictness info, e.g. + (error "urk")
 473                 -- Here, we can't evaluate the arg strictly, because this
 474                 -- partial application might be seq'd
 475
 476     collect_args (Cast fun co) depth
 477         = let (_ty1,ty2) = coercionKind co in
 478           collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 479           returnUs (Cast fun' co, hd, ty2, floats, ss)
 480
 481     collect_args (Note note fun) depth
 482         | ignore_note note      -- Drop these notes altogether
 483                                 -- They aren't used by the code generator
 484         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 485           returnUs (fun', hd, fun_ty, floats, ss)
 486
 487         -- N-variable fun, better let-bind it
 488         -- ToDo: perhaps we can case-bind rather than let-bind this closure,
 489         -- since it is sure to be evaluated.
 490     collect_args fun depth
 491         = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
 492           newVar ty                                     `thenUs` \ fn_id ->
 493           mkLocalNonRec fn_id onceDem fun_floats fun'   `thenUs` \ (floats, fn_id') ->
 494           returnUs (Var fn_id', (Var fn_id', depth), ty, floats, [])
 495         where
 496           ty = exprType fun
 497
 498     ignore_note (CoreNote _) = True
 499     ignore_note InlineMe     = True
 500     ignore_note _other       = False
 501         -- We don't ignore SCCs, since they require some code generation
 502
 503 ------------------------------------------------------------------------------
 504 -- Building the saturated syntax
 505 -- ---------------------------------------------------------------------------
 506
 507 -- maybeSaturate deals with saturating primops and constructors
 508 -- The type is the type of the entire application
 509 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
 510 maybeSaturate fn expr n_args floats ty
 511   | Just DataToTagOp <- isPrimOpId_maybe fn     -- DataToTag must have an evaluated arg
 512                                                 -- A gruesome special case
 513   = saturate_it         `thenUs` \ sat_expr ->
 514
 515         -- OK, now ensure that the arg is evaluated.
 516         -- But (sigh) take into account the lambdas we've now introduced
 517     let
 518         (eta_bndrs, eta_body) = collectBinders sat_expr
 519     in
 520     eval_data2tag_arg eta_body  `thenUs` \ (eta_floats, eta_body') ->
 521     if null eta_bndrs then
 522         returnUs (floats `appendFloats` eta_floats, eta_body')
 523     else
 524         mkBinds eta_floats eta_body'            `thenUs` \ eta_body'' ->
 525         returnUs (floats, mkLams eta_bndrs eta_body'')
 526
 527   | hasNoBinding fn = saturate_it       `thenUs` \ sat_expr ->
 528                       returnUs (floats, sat_expr)
 529
 530   | otherwise       = returnUs (floats, expr)
 531
 532   where
 533     fn_arity     = idArity fn
 534     excess_arity = fn_arity - n_args
 535
 536     saturate_it :: UniqSM CoreExpr
 537     saturate_it | excess_arity == 0 = returnUs expr
 538                 | otherwise         = getUniquesUs              `thenUs` \ us ->
 539                                       returnUs (etaExpand excess_arity us expr ty)
 540
 541         -- Ensure that the argument of DataToTagOp is evaluated
 542     eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
 543     eval_data2tag_arg app@(fun `App` arg)
 544         | exprIsHNF arg         -- Includes nullary constructors
 545         = returnUs (emptyFloats, app)   -- The arg is evaluated
 546         | otherwise                     -- Arg not evaluated, so evaluate it
 547         = newVar (exprType arg)         `thenUs` \ arg_id ->
 548           let
 549              arg_id1 = setIdUnfolding arg_id evaldUnfolding
 550           in
 551           returnUs (unitFloat (FloatCase arg_id1 arg False ),
 552                     fun `App` Var arg_id1)
 553
 554     eval_data2tag_arg (Note note app)   -- Scc notes can appear
 555         = eval_data2tag_arg app         `thenUs` \ (floats, app') ->
 556           returnUs (floats, Note note app')
 557
 558     eval_data2tag_arg other     -- Should not happen
 559         = pprPanic "eval_data2tag" (ppr other)
 560
 561
 562 -- ---------------------------------------------------------------------------
 563 -- Precipitating the floating bindings
 564 -- ---------------------------------------------------------------------------
 565
 566 floatRhs :: TopLevelFlag -> RecFlag
 567          -> Id
 568          -> (Floats, CoreExpr)  -- Rhs: let binds in body
 569          -> UniqSM (Floats,     -- Floats out of this bind
 570                     CoreExpr)   -- Final Rhs
 571
 572 floatRhs top_lvl is_rec bndr (floats, rhs)
 573   | isTopLevel top_lvl || exprIsHNF rhs,        -- Float to expose value or
 574     allLazy top_lvl is_rec floats               -- at top level
 575   =     -- Why the test for allLazy?
 576         --      v = f (x `divInt#` y)
 577         -- we don't want to float the case, even if f has arity 2,
 578         -- because floating the case would make it evaluated too early
 579     returnUs (floats, rhs)
 580
 581   | otherwise
 582         -- Don't float; the RHS isn't a value
 583   = mkBinds floats rhs          `thenUs` \ rhs' ->
 584     returnUs (emptyFloats, rhs')
 585
 586 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
 587 mkLocalNonRec :: Id  -> RhsDemand       -- Lhs: id with demand
 588               -> Floats -> CoreExpr     -- Rhs: let binds in body
 589               -> UniqSM (Floats, Id)    -- The new Id may have an evaldUnfolding,
 590                                         -- to record that it's been evaluated
 591
 592 mkLocalNonRec bndr dem floats rhs
 593   | isUnLiftedType (idType bndr)
 594         -- If this is an unlifted binding, we always make a case for it.
 595   = ASSERT( not (isUnboxedTupleType (idType bndr)) )
 596     let
 597         float = FloatCase bndr rhs (exprOkForSpeculation rhs)
 598     in
 599     returnUs (addFloat floats float, evald_bndr)
 600
 601   | isStrict dem
 602         -- It's a strict let so we definitely float all the bindings
 603  = let          -- Don't make a case for a value binding,
 604                 -- even if it's strict.  Otherwise we get
 605                 --      case (\x -> e) of ...!
 606         float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
 607               | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
 608     in
 609     returnUs (addFloat floats float, evald_bndr)
 610
 611   | otherwise
 612   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)        `thenUs` \ (floats', rhs') ->
 613     returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
 614               if exprIsHNF rhs' then evald_bndr else bndr)
 615
 616   where
 617     evald_bndr = bndr `setIdUnfolding` evaldUnfolding
 618         -- Record if the binder is evaluated
 619
 620
 621 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
 622 mkBinds (Floats _ binds) body
 623   | isNilOL binds = returnUs body
 624   | otherwise     = deLam body          `thenUs` \ body' ->
 625                         -- Lambdas are not allowed as the body of a 'let'
 626                     returnUs (foldrOL mk_bind body' binds)
 627   where
 628     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
 629     mk_bind (FloatLet bind)        body = Let bind body
 630
 631 etaExpandRhs bndr rhs
 632   =     -- Eta expand to match the arity claimed by the binder
 633         -- Remember, after CorePrep we must not change arity
 634         --
 635         -- Eta expansion might not have happened already,
 636         -- because it is done by the simplifier only when
 637         -- there at least one lambda already.
 638         --
 639         -- NB1:we could refrain when the RHS is trivial (which can happen
 640         --     for exported things).  This would reduce the amount of code
 641         --     generated (a little) and make things a little words for
 642         --     code compiled without -O.  The case in point is data constructor
 643         --     wrappers.
 644         --
 645         -- NB2: we have to be careful that the result of etaExpand doesn't
 646         --    invalidate any of the assumptions that CorePrep is attempting
 647         --    to establish.  One possible cause is eta expanding inside of
 648         --    an SCC note - we're now careful in etaExpand to make sure the
 649         --    SCC is pushed inside any new lambdas that are generated.
 650         --
 651         -- NB3: It's important to do eta expansion, and *then* ANF-ising
 652         --              f = /\a -> g (h 3)      -- h has arity 2
 653         -- If we ANF first we get
 654         --              f = /\a -> let s = h 3 in g s
 655         -- and now eta expansion gives
 656         --              f = /\a -> \ y -> (let s = h 3 in g s) y
 657         -- which is horrible.
 658         -- Eta expanding first gives
 659         --              f = /\a -> \y -> let s = h 3 in g s y
 660         --
 661     getUniquesUs                `thenUs` \ us ->
 662     returnUs (etaExpand arity us rhs (idType bndr))
 663   where
 664         -- For a GlobalId, take the Arity from the Id.
 665         -- It was set in CoreTidy and must not change
 666         -- For all others, just expand at will
 667     arity | isGlobalId bndr = idArity bndr
 668           | otherwise       = exprArity rhs
 669
 670 -- ---------------------------------------------------------------------------
 671 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 672 -- We arrange that they only show up as the RHS of a let(rec)
 673 -- ---------------------------------------------------------------------------
 674
 675 deLam :: CoreExpr -> UniqSM CoreExpr
 676 -- Takes an expression that may be a lambda,
 677 -- and returns one that definitely isn't:
 678 --      (\x.e) ==>  let f = \x.e in f
 679 deLam expr =
 680   deLamFloat expr   `thenUs` \ (floats, expr) ->
 681   mkBinds floats expr
 682
 683
 684 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
 685 -- Remove top level lambdas by let-bindinig
 686
 687 deLamFloat (Note n expr)
 688   =     -- You can get things like
 689         --      case e of { p -> coerce t (\s -> ...) }
 690     deLamFloat expr     `thenUs` \ (floats, expr') ->
 691     returnUs (floats, Note n expr')
 692
 693 deLamFloat (Cast e co)
 694   = deLamFloat e        `thenUs` \ (floats, e') ->
 695     returnUs (floats, Cast e' co)
 696
 697 deLamFloat expr
 698   | null bndrs = returnUs (emptyFloats, expr)
 699   | otherwise
 700   = case tryEta bndrs body of
 701       Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
 702       Nothing            -> newVar (exprType expr)      `thenUs` \ fn ->
 703                             returnUs (unitFloat (FloatLet (NonRec fn expr)),
 704                                       Var fn)
 705   where
 706     (bndrs,body) = collectBinders expr
 707
 708 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 709 -- But the simplifier only eta reduces if that leaves something
 710 -- trivial (like f, or f Int).  But for deLam it would be enough to
 711 -- get to a partial application:
 712 --      \xs. map f xs ==> map f
 713
 714 tryEta bndrs expr@(App _ _)
 715   | ok_to_eta_reduce f &&
 716     n_remaining >= 0 &&
 717     and (zipWith ok bndrs last_args) &&
 718     not (any (`elemVarSet` fvs_remaining) bndrs)
 719   = Just remaining_expr
 720   where
 721     (f, args) = collectArgs expr
 722     remaining_expr = mkApps f remaining_args
 723     fvs_remaining = exprFreeVars remaining_expr
 724     (remaining_args, last_args) = splitAt n_remaining args
 725     n_remaining = length args - length bndrs
 726
 727     ok bndr (Var arg) = bndr == arg
 728     ok bndr other     = False
 729
 730           -- we can't eta reduce something which must be saturated.
 731     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 732     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 733
 734 tryEta bndrs (Let bind@(NonRec b r) body)
 735   | not (any (`elemVarSet` fvs) bndrs)
 736   = case tryEta bndrs body of
 737         Just e -> Just (Let bind e)
 738         Nothing -> Nothing
 739   where
 740     fvs = exprFreeVars r
 741
 742 tryEta bndrs _ = Nothing
 743 \end{code}
 744
 745
 746 -- -----------------------------------------------------------------------------
 747 -- Demands
 748 -- -----------------------------------------------------------------------------
 749
 750 \begin{code}
 751 data RhsDemand
 752      = RhsDemand { isStrict :: Bool,  -- True => used at least once
 753                    isOnceDem   :: Bool   -- True => used at most once
 754                  }
 755
 756 mkDem :: Demand -> Bool -> RhsDemand
 757 mkDem strict once = RhsDemand (isStrictDmd strict) once
 758
 759 mkDemTy :: Demand -> Type -> RhsDemand
 760 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
 761                               False {- For now -}
 762
 763 bdrDem :: Id -> RhsDemand
 764 bdrDem id = mkDem (idNewDemandInfo id)
 765                   False {- For now -}
 766
 767 -- safeDem :: RhsDemand
 768 -- safeDem = RhsDemand False False  -- always safe to use this
 769
 770 onceDem :: RhsDemand
 771 onceDem = RhsDemand False True   -- used at most once
 772 \end{code}
 773
 774
 775
 776
 777 %************************************************************************
 778 %*                                                                      *
 779 \subsection{Cloning}
 780 %*                                                                      *
 781 %************************************************************************
 782
 783 \begin{code}
 784 -- ---------------------------------------------------------------------------
 785 --                      The environment
 786 -- ---------------------------------------------------------------------------
 787
 788 data CorePrepEnv = CPE (IdEnv Id)       -- Clone local Ids
 789
 790 emptyCorePrepEnv :: CorePrepEnv
 791 emptyCorePrepEnv = CPE emptyVarEnv
 792
 793 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
 794 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
 795
 796 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
 797 lookupCorePrepEnv (CPE env) id
 798   = case lookupVarEnv env id of
 799         Nothing  -> id
 800         Just id' -> id'
 801
 802 ------------------------------------------------------------------------------
 803 -- Cloning binders
 804 -- ---------------------------------------------------------------------------
 805
 806 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
 807 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 808
 809 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 810 cloneBndr env bndr
 811   | isLocalId bndr
 812   = getUniqueUs   `thenUs` \ uniq ->
 813     let
 814         bndr' = setVarUnique bndr uniq
 815     in
 816     returnUs (extendCorePrepEnv env bndr bndr', bndr')
 817
 818   | otherwise   -- Top level things, which we don't want
 819                 -- to clone, have become GlobalIds by now
 820                 -- And we don't clone tyvars
 821   = returnUs (env, bndr)
 822
 823
 824 ------------------------------------------------------------------------------
 825 -- Cloning ccall Ids; each must have a unique name,
 826 -- to give the code generator a handle to hang it on
 827 -- ---------------------------------------------------------------------------
 828
 829 fiddleCCall :: Id -> UniqSM Id
 830 fiddleCCall id
 831   | isFCallId id = getUniqueUs          `thenUs` \ uniq ->
 832                    returnUs (id `setVarUnique` uniq)
 833   | otherwise    = returnUs id
 834
 835 ------------------------------------------------------------------------------
 836 -- Generating new binders
 837 -- ---------------------------------------------------------------------------
 838
 839 newVar :: Type -> UniqSM Id
 840 newVar ty
 841  = seqType ty                   `seq`
 842    getUniqueUs                  `thenUs` \ uniq ->
 843    returnUs (mkSysLocal FSLIT("sat") uniq ty)
 844 \end{code}