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