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