ghc/compiler/coreSyn/CorePrep.lhs

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