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     (floats, rhs2) <- corePrepExprFloat env rhs
 280     (_, bndr') <- cloneBndr env bndr
 281     (floats', bndr'') <- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2
 282         -- We want bndr'' in the envt, because it records
 283         -- the evaluated-ness of the binder
 284     return (extendCorePrepEnv env bndr bndr'', floats')
 285
 286 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
 287
 288 --------------------------------
 289 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
 290                  -> [(Id,CoreExpr)]     -- Recursive bindings
 291                  -> UniqSM (CorePrepEnv, Floats)
 292 -- Used for all recursive bindings, top level and otherwise
 293 corePrepRecPairs lvl env pairs = do
 294     (env', bndrs') <- cloneBndrs env (map fst pairs)
 295     (floats_s, rhss') <- mapAndUnzipM (corePrepRhs lvl Recursive env') pairs
 296     return (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
 297   where
 298         -- Flatten all the floats, and the currrent
 299         -- group into a single giant Rec
 300     flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
 301
 302     get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
 303     get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
 304     get b                       _    = pprPanic "corePrepRecPairs" (ppr b)
 305
 306 --------------------------------
 307 corePrepRhs :: TopLevelFlag -> RecFlag
 308             -> CorePrepEnv -> (Id, CoreExpr)
 309             -> UniqSM (Floats, CoreExpr)
 310 -- Used for top-level bindings, and local recursive bindings
 311 corePrepRhs top_lvl is_rec env (bndr, rhs) = do
 312     floats_w_rhs <- corePrepExprFloat env rhs
 313     floatRhs top_lvl is_rec bndr floats_w_rhs
 314
 315
 316 -- ---------------------------------------------------------------------------
 317 -- Making arguments atomic (function args & constructor args)
 318 -- ---------------------------------------------------------------------------
 319
 320 -- This is where we arrange that a non-trivial argument is let-bound
 321 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
 322            -> UniqSM (Floats, CoreArg)
 323 corePrepArg env arg dem
 324   = do { (floats, arg') <- corePrepExprFloat env arg
 325        ; if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats
 326               -- Note [Floating unlifted arguments]
 327          then return (floats, arg')
 328          else do { v <- newVar (exprType arg')
 329                         -- Note [Eta expand arguments]
 330                  ; (floats', v') <- mkLocalNonRec v dem floats arg'
 331                  ; return (floats', Var v') } }
 332
 333 -- version that doesn't consider an scc annotation to be trivial.
 334 exprIsTrivial :: CoreExpr -> Bool
 335 exprIsTrivial (Var _)                  = True
 336 exprIsTrivial (Type _)                 = True
 337 exprIsTrivial (Lit _)                  = True
 338 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 339 exprIsTrivial (Note (SCC _) _)         = False
 340 exprIsTrivial (Note _ e)               = exprIsTrivial e
 341 exprIsTrivial (Cast e _)               = exprIsTrivial e
 342 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 343 exprIsTrivial _                        = False
 344 \end{code}
 345
 346 Note [Floating unlifted arguments]
 347 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 348 Consider    C (let v* = expensive in v)
 349
 350 where the "*" indicates "will be demanded".  Usually v will have been
 351 inlined by now, but let's suppose it hasn't (see Trac #2756).  Then we
 352 do *not* want to get
 353
 354      let v* = expensive in C v
 355
 356 because that has different strictness.  Hence the use of 'allLazy'.
 357 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
 358
 359
 360 \begin{code}
 361 -- ---------------------------------------------------------------------------
 362 -- Dealing with expressions
 363 -- ---------------------------------------------------------------------------
 364
 365 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
 366 corePrepAnExpr env expr = do
 367     (floats, expr) <- corePrepExprFloat env expr
 368     mkBinds floats expr
 369
 370
 371 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
 372 -- If
 373 --      e  ===>  (bs, e')
 374 -- then
 375 --      e = let bs in e'        (semantically, that is!)
 376 --
 377 -- For example
 378 --      f (g x)   ===>   ([v = g x], f v)
 379
 380 corePrepExprFloat env (Var v) = do
 381     v1 <- fiddleCCall v
 382     let
 383         v2 = lookupCorePrepEnv env v1
 384     maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
 385
 386 corePrepExprFloat _env expr@(Type _)
 387   = return (emptyFloats, expr)
 388
 389 corePrepExprFloat _env expr@(Lit _)
 390   = return (emptyFloats, expr)
 391
 392 corePrepExprFloat env (Let bind body) = do
 393     (env', new_binds) <- corePrepBind env bind
 394     (floats, new_body) <- corePrepExprFloat env' body
 395     return (new_binds `appendFloats` floats, new_body)
 396
 397 corePrepExprFloat env (Note n@(SCC _) expr) = do
 398     expr1 <- corePrepAnExpr env expr
 399     (floats, expr2) <- deLamFloat expr1
 400     return (floats, Note n expr2)
 401
 402 corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
 403   | Just (TickBox {}) <- isTickBoxOp_maybe id = do
 404     expr1 <- corePrepAnExpr env expr
 405     (floats, expr2) <- deLamFloat expr1
 406     return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
 407
 408 corePrepExprFloat env (Note other_note expr) = do
 409     (floats, expr') <- corePrepExprFloat env expr
 410     return (floats, Note other_note expr')
 411
 412 corePrepExprFloat env (Cast expr co) = do
 413     (floats, expr') <- corePrepExprFloat env expr
 414     return (floats, Cast expr' co)
 415
 416 corePrepExprFloat env expr@(Lam _ _) = do
 417     (env', bndrs') <- cloneBndrs env bndrs
 418     body' <- corePrepAnExpr env' body
 419     return (emptyFloats, mkLams bndrs' body')
 420   where
 421     (bndrs,body) = collectBinders expr
 422
 423 corePrepExprFloat env (Case scrut bndr ty alts) = do
 424     (floats1, scrut1) <- corePrepExprFloat env scrut
 425     (floats2, scrut2) <- deLamFloat scrut1
 426     let
 427         bndr1 = bndr `setIdUnfolding` evaldUnfolding
 428         -- Record that the case binder is evaluated in the alternatives
 429     (env', bndr2) <- cloneBndr env bndr1
 430     alts' <- mapM (sat_alt env') alts
 431     return (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
 432   where
 433     sat_alt env (con, bs, rhs) = do
 434             (env2, bs') <- cloneBndrs env bs
 435             rhs1 <- corePrepAnExpr env2 rhs
 436             rhs2 <- deLam rhs1
 437             return (con, bs', rhs2)
 438
 439 corePrepExprFloat env expr@(App _ _) = do
 440     (app, (head,depth), ty, floats, ss) <- collect_args expr 0
 441     MASSERT(null ss)    -- make sure we used all the strictness info
 442
 443         -- Now deal with the function
 444     case head of
 445       Var fn_id -> maybeSaturate fn_id app depth floats ty
 446       _other    -> return (floats, app)
 447
 448   where
 449
 450     -- Deconstruct and rebuild the application, floating any non-atomic
 451     -- arguments to the outside.  We collect the type of the expression,
 452     -- the head of the application, and the number of actual value arguments,
 453     -- all of which are used to possibly saturate this application if it
 454     -- has a constructor or primop at the head.
 455
 456     collect_args
 457         :: CoreExpr
 458         -> Int                            -- current app depth
 459         -> UniqSM (CoreExpr,              -- the rebuilt expression
 460                    (CoreExpr,Int),        -- the head of the application,
 461                                           -- and no. of args it was applied to
 462                    Type,                  -- type of the whole expr
 463                    Floats,                -- any floats we pulled out
 464                    [Demand])              -- remaining argument demands
 465
 466     collect_args (App fun arg@(Type arg_ty)) depth = do
 467           (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
 468           return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 469
 470     collect_args (App fun arg) depth = do
 471           (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
 472           let
 473               (ss1, ss_rest)   = case ss of
 474                                    (ss1:ss_rest) -> (ss1,     ss_rest)
 475                                    []            -> (lazyDmd, [])
 476               (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
 477                                  splitFunTy_maybe fun_ty
 478
 479           (fs, arg') <- corePrepArg env arg (mkDemTy ss1 arg_ty)
 480           return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
 481
 482     collect_args (Var v) depth = do
 483           v1 <- fiddleCCall v
 484           let v2 = lookupCorePrepEnv env v1
 485           return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
 486         where
 487           stricts = case idNewStrictness v of
 488                         StrictSig (DmdType _ demands _)
 489                             | listLengthCmp demands depth /= GT -> demands
 490                                     -- length demands <= depth
 491                             | otherwise                         -> []
 492                 -- If depth < length demands, then we have too few args to
 493                 -- satisfy strictness  info so we have to  ignore all the
 494                 -- strictness info, e.g. + (error "urk")
 495                 -- Here, we can't evaluate the arg strictly, because this
 496                 -- partial application might be seq'd
 497
 498     collect_args (Cast fun co) depth = do
 499           let (_ty1,ty2) = coercionKind co
 500           (fun', hd, _, floats, ss) <- collect_args fun depth
 501           return (Cast fun' co, hd, ty2, floats, ss)
 502
 503     collect_args (Note note fun) depth
 504         | ignore_note note = do -- Drop these notes altogether
 505                                 -- They aren't used by the code generator
 506           (fun', hd, fun_ty, floats, ss) <- collect_args fun depth
 507           return (fun', hd, fun_ty, floats, ss)
 508
 509         -- N-variable fun, better let-bind it
 510         -- ToDo: perhaps we can case-bind rather than let-bind this closure,
 511         -- since it is sure to be evaluated.
 512     collect_args fun depth = do
 513           (fun_floats, fun') <- corePrepExprFloat env fun
 514           fn_id <- newVar ty
 515           (floats, fn_id') <- mkLocalNonRec fn_id onceDem fun_floats fun'
 516           return (Var fn_id', (Var fn_id', depth), ty, floats, [])
 517         where
 518           ty = exprType fun
 519
 520     ignore_note (CoreNote _) = True
 521     ignore_note _other       = False
 522         -- We don't ignore SCCs, since they require some code generation
 523
 524 ------------------------------------------------------------------------------
 525 -- Building the saturated syntax
 526 -- ---------------------------------------------------------------------------
 527
 528 -- maybeSaturate deals with saturating primops and constructors
 529 -- The type is the type of the entire application
 530 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
 531 maybeSaturate fn expr n_args floats ty
 532   | Just DataToTagOp <- isPrimOpId_maybe fn     -- DataToTag must have an evaluated arg
 533                                                 -- A gruesome special case
 534   = do sat_expr <- saturate_it
 535
 536         -- OK, now ensure that the arg is evaluated.
 537         -- But (sigh) take into account the lambdas we've now introduced
 538        let (eta_bndrs, eta_body) = collectBinders sat_expr
 539        (eta_floats, eta_body') <- eval_data2tag_arg eta_body
 540        if null eta_bndrs then
 541            return (floats `appendFloats` eta_floats, eta_body')
 542         else do
 543            eta_body'' <- mkBinds eta_floats eta_body'
 544            return (floats, mkLams eta_bndrs eta_body'')
 545
 546   | hasNoBinding fn = do sat_expr <- saturate_it
 547                          return (floats, sat_expr)
 548
 549   | otherwise       = return (floats, expr)
 550
 551   where
 552     fn_arity     = idArity fn
 553     excess_arity = fn_arity - n_args
 554
 555     saturate_it :: UniqSM CoreExpr
 556     saturate_it | excess_arity == 0 = return expr
 557                 | otherwise         = do us <- getUniquesM
 558                                          return (etaExpand excess_arity us expr ty)
 559
 560         -- Ensure that the argument of DataToTagOp is evaluated
 561     eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
 562     eval_data2tag_arg app@(fun `App` arg)
 563         | exprIsHNF arg         -- Includes nullary constructors
 564         = return (emptyFloats, app)   -- The arg is evaluated
 565         | otherwise                     -- Arg not evaluated, so evaluate it
 566         = do arg_id <- newVar (exprType arg)
 567              let
 568                 arg_id1 = setIdUnfolding arg_id evaldUnfolding
 569              return (unitFloat (FloatCase arg_id1 arg False ),
 570                      fun `App` Var arg_id1)
 571
 572     eval_data2tag_arg (Note note app)   -- Scc notes can appear
 573         = do (floats, app') <- eval_data2tag_arg app
 574              return (floats, Note note app')
 575
 576     eval_data2tag_arg other     -- Should not happen
 577         = pprPanic "eval_data2tag" (ppr other)
 578
 579
 580 -- ---------------------------------------------------------------------------
 581 -- Precipitating the floating bindings
 582 -- ---------------------------------------------------------------------------
 583
 584 floatRhs :: TopLevelFlag -> RecFlag
 585          -> Id
 586          -> (Floats, CoreExpr)  -- Rhs: let binds in body
 587          -> UniqSM (Floats,     -- Floats out of this bind
 588                     CoreExpr)   -- Final Rhs
 589
 590 floatRhs top_lvl is_rec bndr (floats, rhs)
 591   | isTopLevel top_lvl || exprIsHNF rhs,        -- Float to expose value or
 592     allLazy top_lvl is_rec floats               -- at top level
 593   =     -- Why the test for allLazy?
 594         --      v = f (x `divInt#` y)
 595         -- we don't want to float the case, even if f has arity 2,
 596         -- because floating the case would make it evaluated too early
 597     do { us <- getUniquesM
 598        ; let eta_rhs = etaExpand arity us rhs (idType bndr)
 599                 -- For a GlobalId, take the Arity from the Id.
 600                 -- It was set in CoreTidy and must not change
 601                 -- For all others, just expand at will
 602                 -- See Note [Eta expansion]
 603              arity | isGlobalId bndr = idArity bndr
 604                    | otherwise       = exprArity rhs
 605        ; return (floats, eta_rhs) }
 606
 607   | otherwise = do
 608         -- Don't float; the RHS isn't a value
 609     rhs' <- mkBinds floats rhs
 610     return (emptyFloats, rhs')
 611 \end{code}
 612
 613 Note [Eta expansion]
 614 ~~~~~~~~~~~~~~~~~~~~~
 615 Eta expand to match the arity claimed by the binder Remember,
 616 CorePrep must not change arity
 617
 618 Eta expansion might not have happened already, because it is done by
 619 the simplifier only when there at least one lambda already.
 620
 621 NB1:we could refrain when the RHS is trivial (which can happen
 622     for exported things).  This would reduce the amount of code
 623     generated (a little) and make things a little words for
 624     code compiled without -O.  The case in point is data constructor
 625     wrappers.
 626
 627 NB2: we have to be careful that the result of etaExpand doesn't
 628    invalidate any of the assumptions that CorePrep is attempting
 629    to establish.  One possible cause is eta expanding inside of
 630    an SCC note - we're now careful in etaExpand to make sure the
 631    SCC is pushed inside any new lambdas that are generated.
 632
 633 NB3: It's important to do eta expansion, and *then* ANF-ising
 634                 f = /\a -> g (h 3)      -- h has arity 2
 635 If we ANF first we get
 636                 f = /\a -> let s = h 3 in g s
 637 and now eta expansion gives
 638                 f = /\a -> \ y -> (let s = h 3 in g s) y
 639 which is horrible.
 640 Eta expanding first gives
 641                 f = /\a -> \y -> let s = h 3 in g s y
 642
 643 \begin{code}
 644 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
 645 mkLocalNonRec :: Id  -> RhsDemand       -- Lhs: id with demand
 646               -> Floats -> CoreExpr     -- Rhs: let binds in body
 647               -> UniqSM (Floats, Id)    -- The new Id may have an evaldUnfolding,
 648                                         -- to record that it's been evaluated
 649
 650 mkLocalNonRec bndr dem floats rhs
 651   | isUnLiftedType (idType bndr)
 652         -- If this is an unlifted binding, we always make a case for it.
 653   = ASSERT( not (isUnboxedTupleType (idType bndr)) )
 654     let
 655         float = FloatCase bndr rhs (exprOkForSpeculation rhs)
 656     in
 657     return (addFloat floats float, evald_bndr)
 658
 659   | isStrict dem
 660         -- It's a strict let so we definitely float all the bindings
 661   = let         -- Don't make a case for a value binding,
 662                 -- even if it's strict.  Otherwise we get
 663                 --      case (\x -> e) of ...!
 664         float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
 665               | otherwise     = FloatCase bndr rhs (exprOkForSpeculation rhs)
 666     in
 667     return (addFloat floats float, evald_bndr)
 668
 669   | otherwise
 670   = do (floats', rhs') <- floatRhs NotTopLevel NonRecursive bndr (floats, rhs)
 671        return (addFloat floats' (FloatLet (NonRec bndr rhs')),
 672                if exprIsHNF rhs' then evald_bndr else bndr)
 673
 674   where
 675     evald_bndr = bndr `setIdUnfolding` evaldUnfolding
 676         -- Record if the binder is evaluated
 677
 678
 679 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
 680 mkBinds (Floats _ binds) body
 681   | isNilOL binds = return body
 682   | otherwise     = do body' <- deLam body
 683                         -- Lambdas are not allowed as the body of a 'let'
 684                        return (foldrOL mk_bind body' binds)
 685   where
 686     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
 687     mk_bind (FloatLet bind)        body = Let bind body
 688
 689
 690 -- ---------------------------------------------------------------------------
 691 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 692 -- We arrange that they only show up as the RHS of a let(rec)
 693 -- ---------------------------------------------------------------------------
 694
 695 deLam :: CoreExpr -> UniqSM CoreExpr
 696 -- Takes an expression that may be a lambda,
 697 -- and returns one that definitely isn't:
 698 --      (\x.e) ==>  let f = \x.e in f
 699 deLam expr = do
 700     (floats, expr) <- deLamFloat expr
 701     mkBinds floats expr
 702
 703
 704 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
 705 -- Remove top level lambdas by let-bindinig
 706
 707 deLamFloat (Note n expr) = do
 708         -- You can get things like
 709         --      case e of { p -> coerce t (\s -> ...) }
 710     (floats, expr') <- deLamFloat expr
 711     return (floats, Note n expr')
 712
 713 deLamFloat (Cast e co) = do
 714     (floats, e') <- deLamFloat e
 715     return (floats, Cast e' co)
 716
 717 deLamFloat expr
 718   | null bndrs = return (emptyFloats, expr)
 719   | otherwise
 720   = case tryEta bndrs body of
 721       Just no_lam_result -> return (emptyFloats, no_lam_result)
 722       Nothing            -> do fn <- newVar (exprType expr)
 723                                return (unitFloat (FloatLet (NonRec fn expr)),
 724                                          Var fn)
 725   where
 726     (bndrs,body) = collectBinders expr
 727
 728 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 729 -- But the simplifier only eta reduces if that leaves something
 730 -- trivial (like f, or f Int).  But for deLam it would be enough to
 731 -- get to a partial application:
 732 --      \xs. map f xs ==> map f
 733
 734 tryEta :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
 735 tryEta bndrs expr@(App _ _)
 736   | ok_to_eta_reduce f &&
 737     n_remaining >= 0 &&
 738     and (zipWith ok bndrs last_args) &&
 739     not (any (`elemVarSet` fvs_remaining) bndrs)
 740   = Just remaining_expr
 741   where
 742     (f, args) = collectArgs expr
 743     remaining_expr = mkApps f remaining_args
 744     fvs_remaining = exprFreeVars remaining_expr
 745     (remaining_args, last_args) = splitAt n_remaining args
 746     n_remaining = length args - length bndrs
 747
 748     ok bndr (Var arg) = bndr == arg
 749     ok _    _         = False
 750
 751           -- we can't eta reduce something which must be saturated.
 752     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 753     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 754
 755 tryEta bndrs (Let bind@(NonRec _ r) body)
 756   | not (any (`elemVarSet` fvs) bndrs)
 757   = case tryEta bndrs body of
 758         Just e -> Just (Let bind e)
 759         Nothing -> Nothing
 760   where
 761     fvs = exprFreeVars r
 762
 763 tryEta _ _ = Nothing
 764 \end{code}
 765
 766
 767 -- -----------------------------------------------------------------------------
 768 -- Demands
 769 -- -----------------------------------------------------------------------------
 770
 771 \begin{code}
 772 data RhsDemand
 773      = RhsDemand { isStrict  :: Bool,  -- True => used at least once
 774                   _isOnceDem :: Bool   -- True => used at most once
 775                  }
 776
 777 mkDem :: Demand -> Bool -> RhsDemand
 778 mkDem strict once = RhsDemand (isStrictDmd strict) once
 779
 780 mkDemTy :: Demand -> Type -> RhsDemand
 781 mkDemTy strict _ty = RhsDemand (isStrictDmd strict)
 782                                False {- For now -}
 783
 784 bdrDem :: Id -> RhsDemand
 785 bdrDem id = mkDem (idNewDemandInfo id)
 786                   False {- For now -}
 787
 788 -- safeDem :: RhsDemand
 789 -- safeDem = RhsDemand False False  -- always safe to use this
 790
 791 onceDem :: RhsDemand
 792 onceDem = RhsDemand False True   -- used at most once
 793 \end{code}
 794
 795
 796
 797
 798 %************************************************************************
 799 %*                                                                      *
 800 \subsection{Cloning}
 801 %*                                                                      *
 802 %************************************************************************
 803
 804 \begin{code}
 805 -- ---------------------------------------------------------------------------
 806 --                      The environment
 807 -- ---------------------------------------------------------------------------
 808
 809 data CorePrepEnv = CPE (IdEnv Id)       -- Clone local Ids
 810
 811 emptyCorePrepEnv :: CorePrepEnv
 812 emptyCorePrepEnv = CPE emptyVarEnv
 813
 814 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
 815 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
 816
 817 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
 818 lookupCorePrepEnv (CPE env) id
 819   = case lookupVarEnv env id of
 820         Nothing  -> id
 821         Just id' -> id'
 822
 823 ------------------------------------------------------------------------------
 824 -- Cloning binders
 825 -- ---------------------------------------------------------------------------
 826
 827 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
 828 cloneBndrs env bs = mapAccumLM cloneBndr env bs
 829
 830 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 831 cloneBndr env bndr
 832   | isLocalId bndr
 833   = do bndr' <- setVarUnique bndr <$> getUniqueM
 834        return (extendCorePrepEnv env bndr bndr', bndr')
 835
 836   | otherwise   -- Top level things, which we don't want
 837                 -- to clone, have become GlobalIds by now
 838                 -- And we don't clone tyvars
 839   = return (env, bndr)
 840
 841
 842 ------------------------------------------------------------------------------
 843 -- Cloning ccall Ids; each must have a unique name,
 844 -- to give the code generator a handle to hang it on
 845 -- ---------------------------------------------------------------------------
 846
 847 fiddleCCall :: Id -> UniqSM Id
 848 fiddleCCall id
 849   | isFCallId id = (id `setVarUnique`) <$> getUniqueM
 850   | otherwise    = return id
 851
 852 ------------------------------------------------------------------------------
 853 -- Generating new binders
 854 -- ---------------------------------------------------------------------------
 855
 856 newVar :: Type -> UniqSM Id
 857 newVar ty
 858  = seqType ty `seq` do
 859      uniq <- getUniqueM
 860      return (mkSysLocal (fsLit "sat") uniq ty)
 861 \end{code}