compiler/coreSyn/CorePrep.lhs

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