ghc/compiler/coreSyn/CorePrep.lhs

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