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, repType, seqType )
  19 import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
  20 import PrimOp   ( PrimOp(..) )
  21 import Var      ( Var, Id, setVarUnique )
  22 import VarSet
  23 import VarEnv
  24 import Id       ( mkSysLocal, idType, idNewDemandInfo, idArity,
  25                   setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
  26                   isLocalId, hasNoBinding, idNewStrictness,
  27                   isDataConId_maybe, idUnfolding
  28                 )
  29 import HscTypes ( ModDetails(..), implicitTyThingIds, 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 -> ModDetails -> IO ModDetails
 101 corePrepPgm dflags mod_details
 102   = do  showPass dflags "CorePrep"
 103         us <- mkSplitUniqSupply 's'
 104
 105         let implicit_binds = mkImplicitBinds (md_types mod_details)
 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 (md_binds mod_details)       `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_details { md_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     | id <- implicitTyThingIds (typeEnvElts type_env) ]
 159         -- The etaExpand is so that the manifest arity of the
 160         -- binding matches its claimed arity, which is an
 161         -- invariant of top level bindings going into the code gen
 162
 163 get_unfolding id        -- See notes above
 164   | Just data_con <- isDataConId_maybe id = Var id      -- The ice is thin here, but it works
 165   | otherwise                             = unfoldingTemplate (idUnfolding id)
 166 \end{code}
 167
 168
 169 \begin{code}
 170 -- ---------------------------------------------------------------------------
 171 -- Dealing with bindings
 172 -- ---------------------------------------------------------------------------
 173
 174 data FloatingBind = FloatLet CoreBind
 175                   | FloatCase Id CoreExpr Bool
 176                         -- The bool indicates "ok-for-speculation"
 177
 178 instance Outputable FloatingBind where
 179   ppr (FloatLet bind)        = text "FloatLet" <+> ppr bind
 180   ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
 181
 182 type CloneEnv = IdEnv Id        -- Clone local Ids
 183
 184 deFloatTop :: OrdList FloatingBind -> [CoreBind]
 185 -- For top level only; we don't expect any FloatCases
 186 deFloatTop floats
 187   = foldrOL get [] floats
 188   where
 189     get (FloatLet b) bs = b:bs
 190     get b            bs = pprPanic "corePrepPgm" (ppr b)
 191
 192 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
 193 allLazy top_lvl is_rec floats
 194   = foldrOL check True floats
 195   where
 196     unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
 197
 198     check (FloatLet _)                y = y
 199     check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
 200         -- The ok-for-speculation flag says that it's safe to
 201         -- float this Case out of a let, and thereby do it more eagerly
 202         -- We need the top-level flag because it's never ok to float
 203         -- an unboxed binding to the top level
 204
 205 -- ---------------------------------------------------------------------------
 206 --                      Bindings
 207 -- ---------------------------------------------------------------------------
 208
 209 corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
 210 corePrepTopBinds binds
 211   = go emptyVarEnv binds
 212   where
 213     go env []             = returnUs nilOL
 214     go env (bind : binds) = corePrepTopBind env bind    `thenUs` \ (env', bind') ->
 215                             go env' binds               `thenUs` \ binds' ->
 216                             returnUs (bind' `appOL` binds')
 217
 218 -- NB: we do need to float out of top-level bindings
 219 -- Consider     x = length [True,False]
 220 -- We want to get
 221 --              s1 = False : []
 222 --              s2 = True  : s1
 223 --              x  = length s2
 224
 225 -- We return a *list* of bindings, because we may start with
 226 --      x* = f (g y)
 227 -- where x is demanded, in which case we want to finish with
 228 --      a = g y
 229 --      x* = f a
 230 -- And then x will actually end up case-bound
 231
 232 --------------------------------
 233 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 234 corePrepTopBind env (NonRec bndr rhs)
 235   = cloneBndr env bndr                                  `thenUs` \ (env', bndr') ->
 236     corePrepRhs TopLevel NonRecursive env (bndr, rhs)   `thenUs` \ (floats, rhs') ->
 237     returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
 238
 239 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
 240
 241 --------------------------------
 242 corePrepBind ::  CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 243         -- This one is used for *local* bindings
 244 corePrepBind env (NonRec bndr rhs)
 245   = etaExpandRhs bndr rhs                               `thenUs` \ rhs1 ->
 246     corePrepExprFloat env rhs1                          `thenUs` \ (floats, rhs2) ->
 247     cloneBndr env bndr                                  `thenUs` \ (env', bndr') ->
 248     mkLocalNonRec bndr' (bdrDem bndr') floats rhs2      `thenUs` \ floats' ->
 249     returnUs (env', floats')
 250
 251 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
 252
 253 --------------------------------
 254 corePrepRecPairs :: TopLevelFlag -> CloneEnv
 255                  -> [(Id,CoreExpr)]     -- Recursive bindings
 256                  -> UniqSM (CloneEnv, OrdList FloatingBind)
 257 -- Used for all recursive bindings, top level and otherwise
 258 corePrepRecPairs lvl env pairs
 259   = cloneBndrs env (map fst pairs)                              `thenUs` \ (env', bndrs') ->
 260     mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs        `thenUs` \ (floats_s, rhss') ->
 261     returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
 262   where
 263         -- Flatten all the floats, and the currrent
 264         -- group into a single giant Rec
 265     flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
 266
 267     get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
 268     get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
 269
 270 --------------------------------
 271 corePrepRhs :: TopLevelFlag -> RecFlag
 272             -> CloneEnv -> (Id, CoreExpr)
 273             -> UniqSM (OrdList FloatingBind, CoreExpr)
 274 -- Used for top-level bindings, and local recursive bindings
 275 corePrepRhs top_lvl is_rec env (bndr, rhs)
 276   = etaExpandRhs bndr rhs       `thenUs` \ rhs' ->
 277     corePrepExprFloat env rhs'  `thenUs` \ floats_w_rhs ->
 278     floatRhs top_lvl is_rec bndr floats_w_rhs
 279
 280
 281 -- ---------------------------------------------------------------------------
 282 -- Making arguments atomic (function args & constructor args)
 283 -- ---------------------------------------------------------------------------
 284
 285 -- This is where we arrange that a non-trivial argument is let-bound
 286 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
 287            -> UniqSM (OrdList FloatingBind, CoreArg)
 288 corePrepArg env arg dem
 289   = corePrepExprFloat env arg           `thenUs` \ (floats, arg') ->
 290     if exprIsTrivial arg'
 291     then returnUs (floats, arg')
 292     else newVar (exprType arg')                 `thenUs` \ v ->
 293          mkLocalNonRec v dem floats arg'        `thenUs` \ floats' ->
 294          returnUs (floats', Var v)
 295
 296 -- version that doesn't consider an scc annotation to be trivial.
 297 exprIsTrivial (Var v)                  = True
 298 exprIsTrivial (Type _)                 = True
 299 exprIsTrivial (Lit lit)                = True
 300 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 301 exprIsTrivial (Note (SCC _) e)         = False
 302 exprIsTrivial (Note _ e)               = exprIsTrivial e
 303 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 304 exprIsTrivial other                    = False
 305
 306 -- ---------------------------------------------------------------------------
 307 -- Dealing with expressions
 308 -- ---------------------------------------------------------------------------
 309
 310 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
 311 corePrepAnExpr env expr
 312   = corePrepExprFloat env expr          `thenUs` \ (floats, expr) ->
 313     mkBinds floats expr
 314
 315
 316 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 317 -- If
 318 --      e  ===>  (bs, e')
 319 -- then
 320 --      e = let bs in e'        (semantically, that is!)
 321 --
 322 -- For example
 323 --      f (g x)   ===>   ([v = g x], f v)
 324
 325 corePrepExprFloat env (Var v)
 326   = fiddleCCall v                               `thenUs` \ v1 ->
 327     let v2 = lookupVarEnv env v1 `orElse` v1 in
 328     maybeSaturate v2 (Var v2) 0 (idType v2)     `thenUs` \ app ->
 329     returnUs (nilOL, app)
 330
 331 corePrepExprFloat env expr@(Type _)
 332   = returnUs (nilOL, expr)
 333
 334 corePrepExprFloat env expr@(Lit lit)
 335   = returnUs (nilOL, expr)
 336
 337 corePrepExprFloat env (Let bind body)
 338   = corePrepBind env bind               `thenUs` \ (env', new_binds) ->
 339     corePrepExprFloat env' body         `thenUs` \ (floats, new_body) ->
 340     returnUs (new_binds `appOL` floats, new_body)
 341
 342 corePrepExprFloat env (Note n@(SCC _) expr)
 343   = corePrepAnExpr env expr             `thenUs` \ expr1 ->
 344     deLam expr1                         `thenUs` \ expr2 ->
 345     returnUs (nilOL, Note n expr2)
 346
 347 corePrepExprFloat env (Note other_note expr)
 348   = corePrepExprFloat env expr          `thenUs` \ (floats, expr') ->
 349     returnUs (floats, Note other_note expr')
 350
 351 corePrepExprFloat env expr@(Lam _ _)
 352   = cloneBndrs env bndrs                `thenUs` \ (env', bndrs') ->
 353     corePrepAnExpr env' body            `thenUs` \ body' ->
 354     returnUs (nilOL, mkLams bndrs' body')
 355   where
 356     (bndrs,body) = collectBinders expr
 357
 358 corePrepExprFloat env (Case scrut bndr alts)
 359   = corePrepExprFloat env scrut         `thenUs` \ (floats, scrut') ->
 360     cloneBndr env bndr                  `thenUs` \ (env', bndr') ->
 361     mapUs (sat_alt env') alts           `thenUs` \ alts' ->
 362     returnUs (floats, Case scrut' 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     bndr_rep_ty  = repType bndr_ty
 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 -- Remove top level lambdas by let-bindinig
 584
 585 deLam (Note n expr)
 586   =     -- You can get things like
 587         --      case e of { p -> coerce t (\s -> ...) }
 588     deLam expr  `thenUs` \ expr' ->
 589     returnUs (Note n expr')
 590
 591 deLam expr
 592   | null bndrs = returnUs expr
 593   | otherwise
 594   = case tryEta bndrs body of
 595       Just no_lam_result -> returnUs no_lam_result
 596       Nothing            -> newVar (exprType expr)      `thenUs` \ fn ->
 597                             returnUs (Let (NonRec fn expr) (Var fn))
 598   where
 599     (bndrs,body) = collectBinders expr
 600
 601 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 602 -- But the simplifier only eta reduces if that leaves something
 603 -- trivial (like f, or f Int).  But for deLam it would be enough to
 604 -- get to a partial application, like (map f).
 605
 606 tryEta bndrs expr@(App _ _)
 607   | ok_to_eta_reduce f &&
 608     n_remaining >= 0 &&
 609     and (zipWith ok bndrs last_args) &&
 610     not (any (`elemVarSet` fvs_remaining) bndrs)
 611   = Just remaining_expr
 612   where
 613     (f, args) = collectArgs expr
 614     remaining_expr = mkApps f remaining_args
 615     fvs_remaining = exprFreeVars remaining_expr
 616     (remaining_args, last_args) = splitAt n_remaining args
 617     n_remaining = length args - length bndrs
 618
 619     ok bndr (Var arg) = bndr == arg
 620     ok bndr other           = False
 621
 622           -- we can't eta reduce something which must be saturated.
 623     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 624     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 625
 626 tryEta bndrs (Let bind@(NonRec b r) body)
 627   | not (any (`elemVarSet` fvs) bndrs)
 628   = case tryEta bndrs body of
 629         Just e -> Just (Let bind e)
 630         Nothing -> Nothing
 631   where
 632     fvs = exprFreeVars r
 633
 634 tryEta bndrs _ = Nothing
 635 \end{code}
 636
 637
 638 -- -----------------------------------------------------------------------------
 639 -- Demands
 640 -- -----------------------------------------------------------------------------
 641
 642 \begin{code}
 643 data RhsDemand
 644      = RhsDemand { isStrict :: Bool,  -- True => used at least once
 645                    isOnceDem   :: Bool   -- True => used at most once
 646                  }
 647
 648 mkDem :: Demand -> Bool -> RhsDemand
 649 mkDem strict once = RhsDemand (isStrictDmd strict) once
 650
 651 mkDemTy :: Demand -> Type -> RhsDemand
 652 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
 653                               False {- For now -}
 654
 655 bdrDem :: Id -> RhsDemand
 656 bdrDem id = mkDem (idNewDemandInfo id)
 657                   False {- For now -}
 658
 659 safeDem, onceDem :: RhsDemand
 660 safeDem = RhsDemand False False  -- always safe to use this
 661 onceDem = RhsDemand False True   -- used at most once
 662 \end{code}
 663
 664
 665
 666
 667 %************************************************************************
 668 %*                                                                      *
 669 \subsection{Cloning}
 670 %*                                                                      *
 671 %************************************************************************
 672
 673 \begin{code}
 674 ------------------------------------------------------------------------------
 675 -- Cloning binders
 676 -- ---------------------------------------------------------------------------
 677
 678 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
 679 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 680
 681 cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
 682 cloneBndr env bndr
 683   | isLocalId bndr
 684   = getUniqueUs   `thenUs` \ uniq ->
 685     let
 686         bndr' = setVarUnique bndr uniq
 687     in
 688     returnUs (extendVarEnv env bndr bndr', bndr')
 689
 690   | otherwise   -- Top level things, which we don't want
 691                 -- to clone, have become GlobalIds by now
 692                 -- And we don't clone tyvars
 693   = returnUs (env, bndr)
 694
 695
 696 ------------------------------------------------------------------------------
 697 -- Cloning ccall Ids; each must have a unique name,
 698 -- to give the code generator a handle to hang it on
 699 -- ---------------------------------------------------------------------------
 700
 701 fiddleCCall :: Id -> UniqSM Id
 702 fiddleCCall id
 703   | isFCallId id = getUniqueUs          `thenUs` \ uniq ->
 704                    returnUs (id `setVarUnique` uniq)
 705   | otherwise    = returnUs id
 706
 707 ------------------------------------------------------------------------------
 708 -- Generating new binders
 709 -- ---------------------------------------------------------------------------
 710
 711 newVar :: Type -> UniqSM Id
 712 newVar ty
 713  = seqType ty                   `seq`
 714    getUniqueUs                  `thenUs` \ uniq ->
 715    returnUs (mkSysLocal FSLIT("sat") uniq ty)
 716 \end{code}