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