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