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