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