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