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