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