ghc/compiler/coreSyn/CorePrep.lhs

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