ghc/compiler/coreSyn/CorePrep.lhs

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