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 ( ModGuts(..), ModGuts, 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 -> ModGuts -> IO ModGuts
 100 corePrepPgm dflags mod_impl
 101   = do  showPass dflags "CorePrep"
 102         us <- mkSplitUniqSupply 's'
 103
 104         let implicit_binds = mkImplicitBinds (mg_types mod_impl)
 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 (mg_binds mod_impl)  `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_impl { mg_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         -- ToDo: perhaps we can case-bind rather than let-bind this closure,
 443         -- since it is sure to be evaluated.
 444     collect_args fun depth
 445         = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
 446           newVar ty                                     `thenUs` \ fn_id ->
 447           mkLocalNonRec fn_id onceDem fun_floats fun'   `thenUs` \ floats ->
 448           returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
 449         where
 450           ty = exprType fun
 451
 452     ignore_note InlineCall = True
 453     ignore_note InlineMe   = True
 454     ignore_note _other     = False
 455         -- we don't ignore SCCs, since they require some code generation
 456
 457 ------------------------------------------------------------------------------
 458 -- Building the saturated syntax
 459 -- ---------------------------------------------------------------------------
 460
 461 -- maybeSaturate deals with saturating primops and constructors
 462 -- The type is the type of the entire application
 463 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 464 maybeSaturate fn expr n_args ty
 465   | hasNoBinding fn = saturate_it
 466   | otherwise       = returnUs expr
 467   where
 468     fn_arity     = idArity fn
 469     excess_arity = fn_arity - n_args
 470     saturate_it  = getUniquesUs                 `thenUs` \ us ->
 471                    returnUs (etaExpand excess_arity us expr ty)
 472
 473 -- ---------------------------------------------------------------------------
 474 -- Precipitating the floating bindings
 475 -- ---------------------------------------------------------------------------
 476
 477 floatRhs :: TopLevelFlag -> RecFlag
 478          -> Id
 479          -> (OrdList FloatingBind, CoreExpr)    -- Rhs: let binds in body
 480          -> UniqSM (OrdList FloatingBind,       -- Floats out of this bind
 481                     CoreExpr)                   -- Final Rhs
 482
 483 floatRhs top_lvl is_rec bndr (floats, rhs)
 484   | isTopLevel top_lvl || exprIsValue rhs,      -- Float to expose value or
 485     allLazy top_lvl is_rec floats               -- at top level
 486   =     -- Why the test for allLazy?
 487         --      v = f (x `divInt#` y)
 488         -- we don't want to float the case, even if f has arity 2,
 489         -- because floating the case would make it evaluated too early
 490         --
 491         -- Finally, eta-expand the RHS, for the benefit of the code gen
 492     returnUs (floats, rhs)
 493
 494   | otherwise
 495         -- Don't float; the RHS isn't a value
 496   = mkBinds floats rhs          `thenUs` \ rhs' ->
 497     returnUs (nilOL, rhs')
 498
 499 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
 500 mkLocalNonRec :: Id  -> RhsDemand                       -- Lhs: id with demand
 501               -> OrdList FloatingBind -> CoreExpr       -- Rhs: let binds in body
 502               -> UniqSM (OrdList FloatingBind)
 503
 504 mkLocalNonRec bndr dem floats rhs
 505   | isUnLiftedType (idType bndr)
 506         -- If this is an unlifted binding, we always make a case for it.
 507   = ASSERT( not (isUnboxedTupleType (idType bndr)) )
 508     let
 509         float = FloatCase bndr rhs (exprOkForSpeculation rhs)
 510     in
 511     returnUs (floats `snocOL` float)
 512
 513   | isStrict dem
 514         -- It's a strict let so we definitely float all the bindings
 515  = let          -- Don't make a case for a value binding,
 516                 -- even if it's strict.  Otherwise we get
 517                 --      case (\x -> e) of ...!
 518         float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
 519               | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
 520     in
 521     returnUs (floats `snocOL` float)
 522
 523   | otherwise
 524   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)        `thenUs` \ (floats', rhs') ->
 525     returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
 526
 527   where
 528     bndr_ty      = idType bndr
 529
 530
 531 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 532 mkBinds binds body
 533   | isNilOL binds = returnUs body
 534   | otherwise     = deLam body          `thenUs` \ body' ->
 535                     returnUs (foldrOL mk_bind body' binds)
 536   where
 537     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
 538     mk_bind (FloatLet bind)        body = Let bind body
 539
 540 etaExpandRhs bndr rhs
 541   =     -- Eta expand to match the arity claimed by the binder
 542         -- Remember, after CorePrep we must not change arity
 543         --
 544         -- Eta expansion might not have happened already,
 545         -- because it is done by the simplifier only when
 546         -- there at least one lambda already.
 547         --
 548         -- NB1:we could refrain when the RHS is trivial (which can happen
 549         --     for exported things).  This would reduce the amount of code
 550         --     generated (a little) and make things a little words for
 551         --     code compiled without -O.  The case in point is data constructor
 552         --     wrappers.
 553         --
 554         -- NB2: we have to be careful that the result of etaExpand doesn't
 555         --    invalidate any of the assumptions that CorePrep is attempting
 556         --    to establish.  One possible cause is eta expanding inside of
 557         --    an SCC note - we're now careful in etaExpand to make sure the
 558         --    SCC is pushed inside any new lambdas that are generated.
 559         --
 560         -- NB3: It's important to do eta expansion, and *then* ANF-ising
 561         --              f = /\a -> g (h 3)      -- h has arity 2
 562         -- If we ANF first we get
 563         --              f = /\a -> let s = h 3 in g s
 564         -- and now eta expansion gives
 565         --              f = /\a -> \ y -> (let s = h 3 in g s) y
 566         -- which is horrible.
 567         -- Eta expanding first gives
 568         --              f = /\a -> \y -> let s = h 3 in g s y
 569         --
 570     getUniquesUs                `thenUs` \ us ->
 571     returnUs (etaExpand arity us rhs (idType bndr))
 572   where
 573         -- For a GlobalId, take the Arity from the Id.
 574         -- It was set in CoreTidy and must not change
 575         -- For all others, just expand at will
 576     arity | isGlobalId bndr = idArity bndr
 577           | otherwise       = exprArity rhs
 578
 579 -- ---------------------------------------------------------------------------
 580 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 581 -- We arrange that they only show up as the RHS of a let(rec)
 582 -- ---------------------------------------------------------------------------
 583
 584 deLam :: CoreExpr -> UniqSM CoreExpr
 585 deLam expr =
 586   deLamFloat expr   `thenUs` \ (floats, expr) ->
 587   mkBinds floats expr
 588
 589
 590 deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 591 -- Remove top level lambdas by let-bindinig
 592
 593 deLamFloat (Note n expr)
 594   =     -- You can get things like
 595         --      case e of { p -> coerce t (\s -> ...) }
 596     deLamFloat expr     `thenUs` \ (floats, expr') ->
 597     returnUs (floats, Note n expr')
 598
 599 deLamFloat expr
 600   | null bndrs = returnUs (nilOL, expr)
 601   | otherwise
 602   = case tryEta bndrs body of
 603       Just no_lam_result -> returnUs (nilOL, no_lam_result)
 604       Nothing            -> newVar (exprType expr)      `thenUs` \ fn ->
 605                             returnUs (unitOL (FloatLet (NonRec fn expr)),
 606                                       Var fn)
 607   where
 608     (bndrs,body) = collectBinders expr
 609
 610 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 611 -- But the simplifier only eta reduces if that leaves something
 612 -- trivial (like f, or f Int).  But for deLam it would be enough to
 613 -- get to a partial application, like (map f).
 614
 615 tryEta bndrs expr@(App _ _)
 616   | ok_to_eta_reduce f &&
 617     n_remaining >= 0 &&
 618     and (zipWith ok bndrs last_args) &&
 619     not (any (`elemVarSet` fvs_remaining) bndrs)
 620   = Just remaining_expr
 621   where
 622     (f, args) = collectArgs expr
 623     remaining_expr = mkApps f remaining_args
 624     fvs_remaining = exprFreeVars remaining_expr
 625     (remaining_args, last_args) = splitAt n_remaining args
 626     n_remaining = length args - length bndrs
 627
 628     ok bndr (Var arg) = bndr == arg
 629     ok bndr other           = False
 630
 631           -- we can't eta reduce something which must be saturated.
 632     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 633     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 634
 635 tryEta bndrs (Let bind@(NonRec b r) body)
 636   | not (any (`elemVarSet` fvs) bndrs)
 637   = case tryEta bndrs body of
 638         Just e -> Just (Let bind e)
 639         Nothing -> Nothing
 640   where
 641     fvs = exprFreeVars r
 642
 643 tryEta bndrs _ = Nothing
 644 \end{code}
 645
 646
 647 -- -----------------------------------------------------------------------------
 648 -- Demands
 649 -- -----------------------------------------------------------------------------
 650
 651 \begin{code}
 652 data RhsDemand
 653      = RhsDemand { isStrict :: Bool,  -- True => used at least once
 654                    isOnceDem   :: Bool   -- True => used at most once
 655                  }
 656
 657 mkDem :: Demand -> Bool -> RhsDemand
 658 mkDem strict once = RhsDemand (isStrictDmd strict) once
 659
 660 mkDemTy :: Demand -> Type -> RhsDemand
 661 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
 662                               False {- For now -}
 663
 664 bdrDem :: Id -> RhsDemand
 665 bdrDem id = mkDem (idNewDemandInfo id)
 666                   False {- For now -}
 667
 668 -- safeDem :: RhsDemand
 669 -- safeDem = RhsDemand False False  -- always safe to use this
 670
 671 onceDem :: RhsDemand
 672 onceDem = RhsDemand False True   -- used at most once
 673 \end{code}
 674
 675
 676
 677
 678 %************************************************************************
 679 %*                                                                      *
 680 \subsection{Cloning}
 681 %*                                                                      *
 682 %************************************************************************
 683
 684 \begin{code}
 685 ------------------------------------------------------------------------------
 686 -- Cloning binders
 687 -- ---------------------------------------------------------------------------
 688
 689 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
 690 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 691
 692 cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
 693 cloneBndr env bndr
 694   | isLocalId bndr
 695   = getUniqueUs   `thenUs` \ uniq ->
 696     let
 697         bndr' = setVarUnique bndr uniq
 698     in
 699     returnUs (extendVarEnv env bndr bndr', bndr')
 700
 701   | otherwise   -- Top level things, which we don't want
 702                 -- to clone, have become GlobalIds by now
 703                 -- And we don't clone tyvars
 704   = returnUs (env, bndr)
 705
 706
 707 ------------------------------------------------------------------------------
 708 -- Cloning ccall Ids; each must have a unique name,
 709 -- to give the code generator a handle to hang it on
 710 -- ---------------------------------------------------------------------------
 711
 712 fiddleCCall :: Id -> UniqSM Id
 713 fiddleCCall id
 714   | isFCallId id = getUniqueUs          `thenUs` \ uniq ->
 715                    returnUs (id `setVarUnique` uniq)
 716   | otherwise    = returnUs id
 717
 718 ------------------------------------------------------------------------------
 719 -- Generating new binders
 720 -- ---------------------------------------------------------------------------
 721
 722 newVar :: Type -> UniqSM Id
 723 newVar ty
 724  = seqType ty                   `seq`
 725    getUniqueUs                  `thenUs` \ uniq ->
 726    returnUs (mkSysLocal FSLIT("sat") uniq ty)
 727 \end{code}