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 ( ModGuts(..), ModGuts, 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 -> ModGuts -> IO ModGuts
 101 corePrepPgm dflags mod_impl
 102   = do  showPass dflags "CorePrep"
 103         us <- mkSplitUniqSupply 's'
 104
 105         let implicit_binds = mkImplicitBinds (mg_types mod_impl)
 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 (mg_binds mod_impl)  `thenUs` \ floats1 ->
 111                           corePrepTopBinds implicit_binds       `thenUs` \ floats2 ->
 112                           returnUs (deFloatTop (floats1 `appOL` floats2))
 113                         )
 114
 115         endPass dflags "CorePrep" Opt_D_dump_prep binds_out
 116         return (mod_impl { mg_binds = 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 instance Outputable FloatingBind where
 183   ppr (FloatLet bind)        = text "FloatLet" <+> ppr bind
 184   ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
 185
 186 type CloneEnv = IdEnv Id        -- Clone local Ids
 187
 188 deFloatTop :: OrdList FloatingBind -> [CoreBind]
 189 -- For top level only; we don't expect any FloatCases
 190 deFloatTop floats
 191   = foldrOL get [] floats
 192   where
 193     get (FloatLet b) bs = b:bs
 194     get b            bs = pprPanic "corePrepPgm" (ppr b)
 195
 196 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
 197 allLazy top_lvl is_rec floats
 198   = foldrOL check True floats
 199   where
 200     unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
 201
 202     check (FloatLet _)                y = y
 203     check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
 204         -- The ok-for-speculation flag says that it's safe to
 205         -- float this Case out of a let, and thereby do it more eagerly
 206         -- We need the top-level flag because it's never ok to float
 207         -- an unboxed binding to the top level
 208
 209 -- ---------------------------------------------------------------------------
 210 --                      Bindings
 211 -- ---------------------------------------------------------------------------
 212
 213 corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
 214 corePrepTopBinds binds
 215   = go emptyVarEnv binds
 216   where
 217     go env []             = returnUs nilOL
 218     go env (bind : binds) = corePrepTopBind env bind    `thenUs` \ (env', bind') ->
 219                             go env' binds               `thenUs` \ binds' ->
 220                             returnUs (bind' `appOL` binds')
 221
 222 -- NB: we do need to float out of top-level bindings
 223 -- Consider     x = length [True,False]
 224 -- We want to get
 225 --              s1 = False : []
 226 --              s2 = True  : s1
 227 --              x  = length s2
 228
 229 -- We return a *list* of bindings, because we may start with
 230 --      x* = f (g y)
 231 -- where x is demanded, in which case we want to finish with
 232 --      a = g y
 233 --      x* = f a
 234 -- And then x will actually end up case-bound
 235
 236 --------------------------------
 237 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 238 corePrepTopBind env (NonRec bndr rhs)
 239   = cloneBndr env bndr                                  `thenUs` \ (env', bndr') ->
 240     corePrepRhs TopLevel NonRecursive env (bndr, rhs)   `thenUs` \ (floats, rhs') ->
 241     returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
 242
 243 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
 244
 245 --------------------------------
 246 corePrepBind ::  CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 247         -- This one is used for *local* bindings
 248 corePrepBind env (NonRec bndr rhs)
 249   = etaExpandRhs bndr rhs                               `thenUs` \ rhs1 ->
 250     corePrepExprFloat env rhs1                          `thenUs` \ (floats, rhs2) ->
 251     cloneBndr env bndr                                  `thenUs` \ (env', bndr') ->
 252     mkLocalNonRec bndr' (bdrDem bndr') floats rhs2      `thenUs` \ floats' ->
 253     returnUs (env', floats')
 254
 255 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
 256
 257 --------------------------------
 258 corePrepRecPairs :: TopLevelFlag -> CloneEnv
 259                  -> [(Id,CoreExpr)]     -- Recursive bindings
 260                  -> UniqSM (CloneEnv, OrdList FloatingBind)
 261 -- Used for all recursive bindings, top level and otherwise
 262 corePrepRecPairs lvl env pairs
 263   = cloneBndrs env (map fst pairs)                              `thenUs` \ (env', bndrs') ->
 264     mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs        `thenUs` \ (floats_s, rhss') ->
 265     returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
 266   where
 267         -- Flatten all the floats, and the currrent
 268         -- group into a single giant Rec
 269     flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
 270
 271     get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
 272     get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
 273
 274 --------------------------------
 275 corePrepRhs :: TopLevelFlag -> RecFlag
 276             -> CloneEnv -> (Id, CoreExpr)
 277             -> UniqSM (OrdList FloatingBind, CoreExpr)
 278 -- Used for top-level bindings, and local recursive bindings
 279 corePrepRhs top_lvl is_rec env (bndr, rhs)
 280   = etaExpandRhs bndr rhs       `thenUs` \ rhs' ->
 281     corePrepExprFloat env rhs'  `thenUs` \ floats_w_rhs ->
 282     floatRhs top_lvl is_rec bndr floats_w_rhs
 283
 284
 285 -- ---------------------------------------------------------------------------
 286 -- Making arguments atomic (function args & constructor args)
 287 -- ---------------------------------------------------------------------------
 288
 289 -- This is where we arrange that a non-trivial argument is let-bound
 290 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
 291            -> UniqSM (OrdList FloatingBind, CoreArg)
 292 corePrepArg env arg dem
 293   = corePrepExprFloat env arg           `thenUs` \ (floats, arg') ->
 294     if exprIsTrivial arg'
 295     then returnUs (floats, arg')
 296     else newVar (exprType arg')                 `thenUs` \ v ->
 297          mkLocalNonRec v dem floats arg'        `thenUs` \ floats' ->
 298          returnUs (floats', Var v)
 299
 300 -- version that doesn't consider an scc annotation to be trivial.
 301 exprIsTrivial (Var v)                  = True
 302 exprIsTrivial (Type _)                 = True
 303 exprIsTrivial (Lit lit)                = True
 304 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 305 exprIsTrivial (Note (SCC _) e)         = False
 306 exprIsTrivial (Note _ e)               = exprIsTrivial e
 307 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 308 exprIsTrivial other                    = False
 309
 310 -- ---------------------------------------------------------------------------
 311 -- Dealing with expressions
 312 -- ---------------------------------------------------------------------------
 313
 314 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
 315 corePrepAnExpr env expr
 316   = corePrepExprFloat env expr          `thenUs` \ (floats, expr) ->
 317     mkBinds floats expr
 318
 319
 320 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 321 -- If
 322 --      e  ===>  (bs, e')
 323 -- then
 324 --      e = let bs in e'        (semantically, that is!)
 325 --
 326 -- For example
 327 --      f (g x)   ===>   ([v = g x], f v)
 328
 329 corePrepExprFloat env (Var v)
 330   = fiddleCCall v                               `thenUs` \ v1 ->
 331     let v2 = lookupVarEnv env v1 `orElse` v1 in
 332     maybeSaturate v2 (Var v2) 0 (idType v2)     `thenUs` \ app ->
 333     returnUs (nilOL, app)
 334
 335 corePrepExprFloat env expr@(Type _)
 336   = returnUs (nilOL, expr)
 337
 338 corePrepExprFloat env expr@(Lit lit)
 339   = returnUs (nilOL, expr)
 340
 341 corePrepExprFloat env (Let bind body)
 342   = corePrepBind env bind               `thenUs` \ (env', new_binds) ->
 343     corePrepExprFloat env' body         `thenUs` \ (floats, new_body) ->
 344     returnUs (new_binds `appOL` floats, new_body)
 345
 346 corePrepExprFloat env (Note n@(SCC _) expr)
 347   = corePrepAnExpr env expr             `thenUs` \ expr1 ->
 348     deLamFloat expr1                    `thenUs` \ (floats, expr2) ->
 349     returnUs (floats, Note n expr2)
 350
 351 corePrepExprFloat env (Note other_note expr)
 352   = corePrepExprFloat env expr          `thenUs` \ (floats, expr') ->
 353     returnUs (floats, Note other_note expr')
 354
 355 corePrepExprFloat env expr@(Lam _ _)
 356   = cloneBndrs env bndrs                `thenUs` \ (env', bndrs') ->
 357     corePrepAnExpr env' body            `thenUs` \ body' ->
 358     returnUs (nilOL, mkLams bndrs' body')
 359   where
 360     (bndrs,body) = collectBinders expr
 361
 362 corePrepExprFloat env (Case scrut bndr alts)
 363   = corePrepExprFloat env scrut         `thenUs` \ (floats1, scrut1) ->
 364     deLamFloat scrut1                   `thenUs` \ (floats2, scrut2) ->
 365     cloneBndr env bndr                  `thenUs` \ (env', bndr') ->
 366     mapUs (sat_alt env') alts           `thenUs` \ alts' ->
 367     returnUs (floats1 `appOL` floats2 , Case scrut2 bndr' alts')
 368   where
 369     sat_alt env (con, bs, rhs)
 370           = cloneBndrs env bs           `thenUs` \ (env', bs') ->
 371             corePrepAnExpr env' rhs     `thenUs` \ rhs1 ->
 372             deLam rhs1                  `thenUs` \ rhs2 ->
 373             returnUs (con, bs', rhs2)
 374
 375 corePrepExprFloat env expr@(App _ _)
 376   = collect_args expr 0  `thenUs` \ (app, (head,depth), ty, floats, ss) ->
 377     ASSERT(null ss)     -- make sure we used all the strictness info
 378
 379         -- Now deal with the function
 380     case head of
 381       Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
 382                    returnUs (floats, app')
 383
 384       _other    -> returnUs (floats, app)
 385
 386   where
 387
 388     -- Deconstruct and rebuild the application, floating any non-atomic
 389     -- arguments to the outside.  We collect the type of the expression,
 390     -- the head of the application, and the number of actual value arguments,
 391     -- all of which are used to possibly saturate this application if it
 392     -- has a constructor or primop at the head.
 393
 394     collect_args
 395         :: CoreExpr
 396         -> Int                            -- current app depth
 397         -> UniqSM (CoreExpr,              -- the rebuilt expression
 398                    (CoreExpr,Int),        -- the head of the application,
 399                                           -- and no. of args it was applied to
 400                    Type,                  -- type of the whole expr
 401                    OrdList FloatingBind,  -- any floats we pulled out
 402                    [Demand])              -- remaining argument demands
 403
 404     collect_args (App fun arg@(Type arg_ty)) depth
 405         = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 406           returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 407
 408     collect_args (App fun arg) depth
 409         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 410           let
 411               (ss1, ss_rest)   = case ss of
 412                                    (ss1:ss_rest) -> (ss1,     ss_rest)
 413                                    []            -> (lazyDmd, [])
 414               (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
 415                                  splitFunTy_maybe fun_ty
 416           in
 417           corePrepArg env arg (mkDemTy ss1 arg_ty)      `thenUs` \ (fs, arg') ->
 418           returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
 419
 420     collect_args (Var v) depth
 421         = fiddleCCall v `thenUs` \ v1 ->
 422           let v2 = lookupVarEnv env v1 `orElse` v1 in
 423           returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
 424         where
 425           stricts = case idNewStrictness v of
 426                         StrictSig (DmdType _ demands _)
 427                             | listLengthCmp demands depth /= GT -> demands
 428                                     -- length demands <= depth
 429                             | otherwise                         -> []
 430                 -- If depth < length demands, then we have too few args to
 431                 -- satisfy strictness  info so we have to  ignore all the
 432                 -- strictness info, e.g. + (error "urk")
 433                 -- Here, we can't evaluate the arg strictly, because this
 434                 -- partial application might be seq'd
 435
 436
 437     collect_args (Note (Coerce ty1 ty2) fun) depth
 438         = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 439           returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 440
 441     collect_args (Note note fun) depth
 442         | ignore_note note
 443         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 444           returnUs (Note note fun', hd, fun_ty, floats, ss)
 445
 446         -- non-variable fun, better let-bind it
 447         -- ToDo: perhaps we can case-bind rather than let-bind this closure,
 448         -- since it is sure to be evaluated.
 449     collect_args fun depth
 450         = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
 451           newVar ty                                     `thenUs` \ fn_id ->
 452           mkLocalNonRec fn_id onceDem fun_floats fun'   `thenUs` \ floats ->
 453           returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
 454         where
 455           ty = exprType fun
 456
 457     ignore_note (CoreNote _) = True
 458     ignore_note InlineCall   = True
 459     ignore_note InlineMe     = True
 460     ignore_note _other       = False
 461         -- We don't ignore SCCs, since they require some code generation
 462
 463 ------------------------------------------------------------------------------
 464 -- Building the saturated syntax
 465 -- ---------------------------------------------------------------------------
 466
 467 -- maybeSaturate deals with saturating primops and constructors
 468 -- The type is the type of the entire application
 469 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 470 maybeSaturate fn expr n_args ty
 471   | hasNoBinding fn = saturate_it
 472   | otherwise       = returnUs expr
 473   where
 474     fn_arity     = idArity fn
 475     excess_arity = fn_arity - n_args
 476     saturate_it  = getUniquesUs                 `thenUs` \ us ->
 477                    returnUs (etaExpand excess_arity us expr ty)
 478
 479 -- ---------------------------------------------------------------------------
 480 -- Precipitating the floating bindings
 481 -- ---------------------------------------------------------------------------
 482
 483 floatRhs :: TopLevelFlag -> RecFlag
 484          -> Id
 485          -> (OrdList FloatingBind, CoreExpr)    -- Rhs: let binds in body
 486          -> UniqSM (OrdList FloatingBind,       -- Floats out of this bind
 487                     CoreExpr)                   -- Final Rhs
 488
 489 floatRhs top_lvl is_rec bndr (floats, rhs)
 490   | isTopLevel top_lvl || exprIsValue rhs,      -- Float to expose value or
 491     allLazy top_lvl is_rec floats               -- at top level
 492   =     -- Why the test for allLazy?
 493         --      v = f (x `divInt#` y)
 494         -- we don't want to float the case, even if f has arity 2,
 495         -- because floating the case would make it evaluated too early
 496         --
 497         -- Finally, eta-expand the RHS, for the benefit of the code gen
 498     returnUs (floats, rhs)
 499
 500   | otherwise
 501         -- Don't float; the RHS isn't a value
 502   = mkBinds floats rhs          `thenUs` \ rhs' ->
 503     returnUs (nilOL, rhs')
 504
 505 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
 506 mkLocalNonRec :: Id  -> RhsDemand                       -- Lhs: id with demand
 507               -> OrdList FloatingBind -> CoreExpr       -- Rhs: let binds in body
 508               -> UniqSM (OrdList FloatingBind)
 509
 510 mkLocalNonRec bndr dem floats rhs
 511   | isUnLiftedType (idType bndr)
 512         -- If this is an unlifted binding, we always make a case for it.
 513   = ASSERT( not (isUnboxedTupleType (idType bndr)) )
 514     let
 515         float = FloatCase bndr rhs (exprOkForSpeculation rhs)
 516     in
 517     returnUs (floats `snocOL` float)
 518
 519   | isStrict dem
 520         -- It's a strict let so we definitely float all the bindings
 521  = let          -- Don't make a case for a value binding,
 522                 -- even if it's strict.  Otherwise we get
 523                 --      case (\x -> e) of ...!
 524         float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
 525               | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
 526     in
 527     returnUs (floats `snocOL` float)
 528
 529   | otherwise
 530   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)        `thenUs` \ (floats', rhs') ->
 531     returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
 532
 533   where
 534     bndr_ty      = idType bndr
 535
 536
 537 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 538 mkBinds binds body
 539   | isNilOL binds = returnUs body
 540   | otherwise     = deLam body          `thenUs` \ body' ->
 541                     returnUs (foldrOL mk_bind body' binds)
 542   where
 543     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
 544     mk_bind (FloatLet bind)        body = Let bind body
 545
 546 etaExpandRhs bndr rhs
 547   =     -- Eta expand to match the arity claimed by the binder
 548         -- Remember, after CorePrep we must not change arity
 549         --
 550         -- Eta expansion might not have happened already,
 551         -- because it is done by the simplifier only when
 552         -- there at least one lambda already.
 553         --
 554         -- NB1:we could refrain when the RHS is trivial (which can happen
 555         --     for exported things).  This would reduce the amount of code
 556         --     generated (a little) and make things a little words for
 557         --     code compiled without -O.  The case in point is data constructor
 558         --     wrappers.
 559         --
 560         -- NB2: we have to be careful that the result of etaExpand doesn't
 561         --    invalidate any of the assumptions that CorePrep is attempting
 562         --    to establish.  One possible cause is eta expanding inside of
 563         --    an SCC note - we're now careful in etaExpand to make sure the
 564         --    SCC is pushed inside any new lambdas that are generated.
 565         --
 566         -- NB3: It's important to do eta expansion, and *then* ANF-ising
 567         --              f = /\a -> g (h 3)      -- h has arity 2
 568         -- If we ANF first we get
 569         --              f = /\a -> let s = h 3 in g s
 570         -- and now eta expansion gives
 571         --              f = /\a -> \ y -> (let s = h 3 in g s) y
 572         -- which is horrible.
 573         -- Eta expanding first gives
 574         --              f = /\a -> \y -> let s = h 3 in g s y
 575         --
 576     getUniquesUs                `thenUs` \ us ->
 577     returnUs (etaExpand arity us rhs (idType bndr))
 578   where
 579         -- For a GlobalId, take the Arity from the Id.
 580         -- It was set in CoreTidy and must not change
 581         -- For all others, just expand at will
 582     arity | isGlobalId bndr = idArity bndr
 583           | otherwise       = exprArity rhs
 584
 585 -- ---------------------------------------------------------------------------
 586 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 587 -- We arrange that they only show up as the RHS of a let(rec)
 588 -- ---------------------------------------------------------------------------
 589
 590 deLam :: CoreExpr -> UniqSM CoreExpr
 591 deLam expr =
 592   deLamFloat expr   `thenUs` \ (floats, expr) ->
 593   mkBinds floats expr
 594
 595
 596 deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 597 -- Remove top level lambdas by let-bindinig
 598
 599 deLamFloat (Note n expr)
 600   =     -- You can get things like
 601         --      case e of { p -> coerce t (\s -> ...) }
 602     deLamFloat expr     `thenUs` \ (floats, expr') ->
 603     returnUs (floats, Note n expr')
 604
 605 deLamFloat expr
 606   | null bndrs = returnUs (nilOL, expr)
 607   | otherwise
 608   = case tryEta bndrs body of
 609       Just no_lam_result -> returnUs (nilOL, no_lam_result)
 610       Nothing            -> newVar (exprType expr)      `thenUs` \ fn ->
 611                             returnUs (unitOL (FloatLet (NonRec fn expr)),
 612                                       Var fn)
 613   where
 614     (bndrs,body) = collectBinders expr
 615
 616 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 617 -- But the simplifier only eta reduces if that leaves something
 618 -- trivial (like f, or f Int).  But for deLam it would be enough to
 619 -- get to a partial application, like (map f).
 620
 621 tryEta bndrs expr@(App _ _)
 622   | ok_to_eta_reduce f &&
 623     n_remaining >= 0 &&
 624     and (zipWith ok bndrs last_args) &&
 625     not (any (`elemVarSet` fvs_remaining) bndrs)
 626   = Just remaining_expr
 627   where
 628     (f, args) = collectArgs expr
 629     remaining_expr = mkApps f remaining_args
 630     fvs_remaining = exprFreeVars remaining_expr
 631     (remaining_args, last_args) = splitAt n_remaining args
 632     n_remaining = length args - length bndrs
 633
 634     ok bndr (Var arg) = bndr == arg
 635     ok bndr other     = False
 636
 637           -- we can't eta reduce something which must be saturated.
 638     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 639     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 640
 641 tryEta bndrs (Let bind@(NonRec b r) body)
 642   | not (any (`elemVarSet` fvs) bndrs)
 643   = case tryEta bndrs body of
 644         Just e -> Just (Let bind e)
 645         Nothing -> Nothing
 646   where
 647     fvs = exprFreeVars r
 648
 649 tryEta bndrs _ = Nothing
 650 \end{code}
 651
 652
 653 -- -----------------------------------------------------------------------------
 654 -- Demands
 655 -- -----------------------------------------------------------------------------
 656
 657 \begin{code}
 658 data RhsDemand
 659      = RhsDemand { isStrict :: Bool,  -- True => used at least once
 660                    isOnceDem   :: Bool   -- True => used at most once
 661                  }
 662
 663 mkDem :: Demand -> Bool -> RhsDemand
 664 mkDem strict once = RhsDemand (isStrictDmd strict) once
 665
 666 mkDemTy :: Demand -> Type -> RhsDemand
 667 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
 668                               False {- For now -}
 669
 670 bdrDem :: Id -> RhsDemand
 671 bdrDem id = mkDem (idNewDemandInfo id)
 672                   False {- For now -}
 673
 674 -- safeDem :: RhsDemand
 675 -- safeDem = RhsDemand False False  -- always safe to use this
 676
 677 onceDem :: RhsDemand
 678 onceDem = RhsDemand False True   -- used at most once
 679 \end{code}
 680
 681
 682
 683
 684 %************************************************************************
 685 %*                                                                      *
 686 \subsection{Cloning}
 687 %*                                                                      *
 688 %************************************************************************
 689
 690 \begin{code}
 691 ------------------------------------------------------------------------------
 692 -- Cloning binders
 693 -- ---------------------------------------------------------------------------
 694
 695 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
 696 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 697
 698 cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
 699 cloneBndr env bndr
 700   | isLocalId bndr
 701   = getUniqueUs   `thenUs` \ uniq ->
 702     let
 703         bndr' = setVarUnique bndr uniq
 704     in
 705     returnUs (extendVarEnv env bndr bndr', bndr')
 706
 707   | otherwise   -- Top level things, which we don't want
 708                 -- to clone, have become GlobalIds by now
 709                 -- And we don't clone tyvars
 710   = returnUs (env, bndr)
 711
 712
 713 ------------------------------------------------------------------------------
 714 -- Cloning ccall Ids; each must have a unique name,
 715 -- to give the code generator a handle to hang it on
 716 -- ---------------------------------------------------------------------------
 717
 718 fiddleCCall :: Id -> UniqSM Id
 719 fiddleCCall id
 720   | isFCallId id = getUniqueUs          `thenUs` \ uniq ->
 721                    returnUs (id `setVarUnique` uniq)
 722   | otherwise    = returnUs id
 723
 724 ------------------------------------------------------------------------------
 725 -- Generating new binders
 726 -- ---------------------------------------------------------------------------
 727
 728 newVar :: Type -> UniqSM Id
 729 newVar ty
 730  = seqType ty                   `seq`
 731    getUniqueUs                  `thenUs` \ uniq ->
 732    returnUs (mkSysLocal FSLIT("sat") uniq ty)
 733 \end{code}