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 PrelNames        ( lazyIdKey, hasKey )
  15 import CoreUtils
  16 import CoreArity
  17 import CoreFVs
  18 import CoreLint
  19 import CoreSyn
  20 import Type
  21 import Coercion
  22 import TyCon
  23 import NewDemand
  24 import Var
  25 import VarSet
  26 import VarEnv
  27 import Id
  28 import IdInfo
  29 import DataCon
  30 import PrimOp
  31 import BasicTypes
  32 import UniqSupply
  33 import Maybes
  34 import OrdList
  35 import ErrUtils
  36 import DynFlags
  37 import Util
  38 import Outputable
  39 import MonadUtils
  40 import FastString
  41 import Control.Monad
  42 \end{code}
  43
  44 -- ---------------------------------------------------------------------------
  45 -- Overview
  46 -- ---------------------------------------------------------------------------
  47
  48 The goal of this pass is to prepare for code generation.
  49
  50 1.  Saturate constructor and primop applications.
  51
  52 2.  Convert to A-normal form; that is, function arguments
  53     are always variables.
  54
  55     * Use case for strict arguments:
  56         f E ==> case E of x -> f x
  57         (where f is strict)
  58
  59     * Use let for non-trivial lazy arguments
  60         f E ==> let x = E in f x
  61         (were f is lazy and x is non-trivial)
  62
  63 3.  Similarly, convert any unboxed lets into cases.
  64     [I'm experimenting with leaving 'ok-for-speculation'
  65      rhss in let-form right up to this point.]
  66
  67 4.  Ensure that *value* lambdas only occur as the RHS of a binding
  68     (The code generator can't deal with anything else.)
  69     Type lambdas are ok, however, because the code gen discards them.
  70
  71 5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
  72
  73 6.  Clone all local Ids.
  74     This means that all such Ids are unique, rather than the
  75     weaker guarantee of no clashes which the simplifier provides.
  76     And that is what the code generator needs.
  77
  78     We don't clone TyVars. The code gen doesn't need that,
  79     and doing so would be tiresome because then we'd need
  80     to substitute in types.
  81
  82
  83 7.  Give each dynamic CCall occurrence a fresh unique; this is
  84     rather like the cloning step above.
  85
  86 8.  Inject bindings for the "implicit" Ids:
  87         * Constructor wrappers
  88         * Constructor workers
  89     We want curried definitions for all of these in case they
  90     aren't inlined by some caller.
  91
  92 9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.lhs
  93
  94 This is all done modulo type applications and abstractions, so that
  95 when type erasure is done for conversion to STG, we don't end up with
  96 any trivial or useless bindings.
  97
  98
  99 Invariants
 100 ~~~~~~~~~~
 101 Here is the syntax of the Core produced by CorePrep:
 102
 103     Trivial expressions
 104        triv ::= lit |  var  | triv ty  |  /\a. triv  |  triv |> co
 105
 106     Applications
 107        app ::= lit  |  var  |  app triv  |  app ty  |  app |> co
 108
 109     Expressions
 110        body ::= app
 111               | let(rec) x = rhs in body     -- Boxed only
 112               | case body of pat -> body
 113               | /\a. body
 114               | body |> co
 115
 116     Right hand sides (only place where lambdas can occur)
 117        rhs ::= /\a.rhs  |  \x.rhs  |  body
 118
 119 We define a synonym for each of these non-terminals.  Functions
 120 with the corresponding name produce a result in that syntax.
 121
 122 \begin{code}
 123 type CpeTriv = CoreExpr    -- Non-terminal 'triv'
 124 type CpeApp  = CoreExpr    -- Non-terminal 'app'
 125 type CpeBody = CoreExpr    -- Non-terminal 'body'
 126 type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 127 \end{code}
 128
 129 %************************************************************************
 130 %*                                                                      *
 131                 Top level stuff
 132 %*                                                                      *
 133 %************************************************************************
 134
 135 \begin{code}
 136 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
 137 corePrepPgm dflags binds data_tycons = do
 138     showPass dflags "CorePrep"
 139     us <- mkSplitUniqSupply 's'
 140
 141     let implicit_binds = mkDataConWorkers data_tycons
 142             -- NB: we must feed mkImplicitBinds through corePrep too
 143             -- so that they are suitably cloned and eta-expanded
 144
 145         binds_out = initUs_ us $ do
 146                       floats1 <- corePrepTopBinds binds
 147                       floats2 <- corePrepTopBinds implicit_binds
 148                       return (deFloatTop (floats1 `appendFloats` floats2))
 149
 150     endPass dflags "CorePrep" Opt_D_dump_prep binds_out
 151     return binds_out
 152
 153 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 154 corePrepExpr dflags expr = do
 155     showPass dflags "CorePrep"
 156     us <- mkSplitUniqSupply 's'
 157     let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr)
 158     dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
 159     return new_expr
 160
 161 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
 162 -- Note [Floating out of top level bindings]
 163 corePrepTopBinds binds
 164   = go emptyCorePrepEnv binds
 165   where
 166     go _   []             = return emptyFloats
 167     go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
 168                                binds' <- go env' binds
 169                                return (bind' `appendFloats` binds')
 170
 171 mkDataConWorkers :: [TyCon] -> [CoreBind]
 172 -- See Note [Data constructor workers]
 173 mkDataConWorkers data_tycons
 174   = [ NonRec id (Var id)        -- The ice is thin here, but it works
 175     | tycon <- data_tycons,     -- CorePrep will eta-expand it
 176       data_con <- tyConDataCons tycon,
 177       let id = dataConWorkId data_con ]
 178 \end{code}
 179
 180 Note [Floating out of top level bindings]
 181 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 182 NB: we do need to float out of top-level bindings
 183 Consider        x = length [True,False]
 184 We want to get
 185                 s1 = False : []
 186                 s2 = True  : s1
 187                 x  = length s2
 188
 189 We return a *list* of bindings, because we may start with
 190         x* = f (g y)
 191 where x is demanded, in which case we want to finish with
 192         a = g y
 193         x* = f a
 194 And then x will actually end up case-bound
 195
 196 Note [CafInfo and floating]
 197 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 198 What happens to the CafInfo on the floated bindings?  By default, all
 199 the CafInfos will be set to MayHaveCafRefs, which is safe.
 200
 201 This might be pessimistic, because the floated binding might not refer
 202 to any CAFs and the GC will end up doing more traversal than is
 203 necessary, but it's still better than not floating the bindings at
 204 all, because then the GC would have to traverse the structure in the
 205 heap instead.  Given this, we decided not to try to get the CafInfo on
 206 the floated bindings correct, because it looks difficult.
 207
 208 But that means we can't float anything out of a NoCafRefs binding.
 209 Consider       f = g (h x)
 210 If f is NoCafRefs, we don't want to convert to
 211                sat = h x
 212                f = g sat
 213 where sat conservatively says HasCafRefs, because now f's info
 214 is wrong.  I don't think this is common, so we simply switch off
 215 floating in this case.
 216
 217 Note [Data constructor workers]
 218 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 219 Create any necessary "implicit" bindings for data con workers.  We
 220 create the rather strange (non-recursive!) binding
 221
 222         $wC = \x y -> $wC x y
 223
 224 i.e. a curried constructor that allocates.  This means that we can
 225 treat the worker for a constructor like any other function in the rest
 226 of the compiler.  The point here is that CoreToStg will generate a
 227 StgConApp for the RHS, rather than a call to the worker (which would
 228 give a loop).  As Lennart says: the ice is thin here, but it works.
 229
 230 Hmm.  Should we create bindings for dictionary constructors?  They are
 231 always fully applied, and the bindings are just there to support
 232 partial applications. But it's easier to let them through.
 233
 234
 235 %************************************************************************
 236 %*                                                                      *
 237                 The main code
 238 %*                                                                      *
 239 %************************************************************************
 240
 241 \begin{code}
 242 cpeBind :: TopLevelFlag
 243         -> CorePrepEnv -> CoreBind
 244         -> UniqSM (CorePrepEnv, Floats)
 245 cpeBind top_lvl env (NonRec bndr rhs)
 246   = do { (_, bndr1) <- cloneBndr env bndr
 247        ; let is_strict   = isStrictDmd (idNewDemandInfo bndr)
 248              is_unlifted = isUnLiftedType (idType bndr)
 249        ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
 250                                           (is_strict || is_unlifted)
 251                                           env bndr1 rhs
 252        ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
 253
 254         -- We want bndr'' in the envt, because it records
 255         -- the evaluated-ness of the binder
 256        ; return (extendCorePrepEnv env bndr bndr2,
 257                  addFloat floats new_float) }
 258
 259 cpeBind top_lvl env (Rec pairs)
 260   = do { let (bndrs,rhss) = unzip pairs
 261        ; (env', bndrs1) <- cloneBndrs env (map fst pairs)
 262        ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
 263
 264        ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
 265              all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
 266                                            (concatFloats floats_s)
 267        ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
 268                  unitFloat (FloatLet (Rec all_pairs))) }
 269   where
 270         -- Flatten all the floats, and the currrent
 271         -- group into a single giant Rec
 272     add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
 273     add_float (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
 274     add_float b                       _    = pprPanic "cpeBind" (ppr b)
 275
 276 ---------------
 277 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
 278         -> CorePrepEnv -> Id -> CoreExpr
 279         -> UniqSM (Floats, Id, CoreExpr)
 280 -- Used for all bindings
 281 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
 282   = do { (floats1, rhs1) <- cpeRhsE env rhs
 283        ; let (rhs1_bndrs, _) = collectBinders rhs1
 284        ; (floats2, rhs2)
 285             <- if want_float floats1 rhs1
 286                then return (floats1, rhs1)
 287                else -- Non-empty floats will wrap rhs1
 288                     -- But: rhs1 might have lambdas, and we can't
 289                     --      put them inside a wrapBinds
 290                if valBndrCount rhs1_bndrs <= arity
 291                then    -- Lambdas in rhs1 will be nuked by eta expansion
 292                     return (emptyFloats, wrapBinds floats1 rhs1)
 293
 294                else do { body1 <- rhsToBodyNF rhs1
 295                        ; return (emptyFloats, wrapBinds floats1 body1) }
 296
 297        ; (floats3, rhs')   -- Note [Silly extra arguments]
 298             <- if manifestArity rhs2 <= arity
 299                then return (floats2, cpeEtaExpand arity rhs2)
 300                else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
 301                     (do { v <- newVar (idType bndr)
 302                         ; let float = mkFloat False False v rhs2
 303                         ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
 304
 305                 -- Record if the binder is evaluated
 306        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
 307                    | otherwise      = bndr
 308
 309        ; return (floats3, bndr', rhs') }
 310   where
 311     arity = idArity bndr        -- We must match this arity
 312     want_float floats rhs
 313      | isTopLevel top_lvl = wantFloatTop bndr floats
 314      | otherwise          = wantFloatNested is_rec is_strict_or_unlifted floats rhs
 315
 316 {- Note [Silly extra arguments]
 317 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 318 Suppose we had this
 319         f{arity=1} = \x\y. e
 320 We *must* match the arity on the Id, so we have to generate
 321         f' = \x\y. e
 322         f  = \x. f' x
 323
 324 It's a bizarre case: why is the arity on the Id wrong?  Reason
 325 (in the days of __inline_me__):
 326         f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
 327 When InlineMe notes go away this won't happen any more.  But
 328 it seems good for CorePrep to be robust.
 329 -}
 330
 331 -- ---------------------------------------------------------------------------
 332 --              CpeRhs: produces a result satisfying CpeRhs
 333 -- ---------------------------------------------------------------------------
 334
 335 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 336 -- If
 337 --      e  ===>  (bs, e')
 338 -- then
 339 --      e = let bs in e'        (semantically, that is!)
 340 --
 341 -- For example
 342 --      f (g x)   ===>   ([v = g x], f v)
 343
 344 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
 345 cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)
 346 cpeRhsE env expr@(Var {})  = cpeApp env expr
 347
 348 cpeRhsE env (Var f `App` _ `App` arg)
 349   | f `hasKey` lazyIdKey          -- Replace (lazy a) by a
 350   = cpeRhsE env arg               -- See Note [lazyId magic] in MkId
 351
 352 cpeRhsE env expr@(App {}) = cpeApp env expr
 353
 354 cpeRhsE env (Let bind expr)
 355   = do { (env', new_binds) <- cpeBind NotTopLevel env bind
 356        ; (floats, body) <- cpeRhsE env' expr
 357        ; return (new_binds `appendFloats` floats, body) }
 358
 359 cpeRhsE env (Note note expr)
 360   | ignoreNote note
 361   = cpeRhsE env expr
 362   | otherwise         -- Just SCCs actually
 363   = do { body <- cpeBodyNF env expr
 364        ; return (emptyFloats, Note note body) }
 365
 366 cpeRhsE env (Cast expr co)
 367    = do { (floats, expr') <- cpeRhsE env expr
 368         ; return (floats, Cast expr' co) }
 369
 370 cpeRhsE env expr@(Lam {})
 371    = do { let (bndrs,body) = collectBinders expr
 372         ; (env', bndrs') <- cloneBndrs env bndrs
 373         ; body' <- cpeBodyNF env' body
 374         ; return (emptyFloats, mkLams bndrs' body') }
 375
 376 cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
 377   | Just (TickBox {}) <- isTickBoxOp_maybe id
 378   = do { body <- cpeBodyNF env expr
 379        ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) }
 380
 381 cpeRhsE env (Case scrut bndr ty alts)
 382   = do { (floats, scrut') <- cpeBody env scrut
 383        ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
 384             -- Record that the case binder is evaluated in the alternatives
 385        ; (env', bndr2) <- cloneBndr env bndr1
 386        ; alts' <- mapM (sat_alt env') alts
 387        ; return (floats, Case scrut' bndr2 ty alts') }
 388   where
 389     sat_alt env (con, bs, rhs)
 390        = do { (env2, bs') <- cloneBndrs env bs
 391             ; rhs' <- cpeBodyNF env2 rhs
 392             ; return (con, bs', rhs') }
 393
 394 -- ---------------------------------------------------------------------------
 395 --              CpeBody: produces a result satisfying CpeBody
 396 -- ---------------------------------------------------------------------------
 397
 398 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
 399 cpeBodyNF env expr
 400   = do { (floats, body) <- cpeBody env expr
 401        ; return (wrapBinds floats body) }
 402
 403 --------
 404 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
 405 cpeBody env expr
 406   = do { (floats1, rhs) <- cpeRhsE env expr
 407        ; (floats2, body) <- rhsToBody rhs
 408        ; return (floats1 `appendFloats` floats2, body) }
 409
 410 --------
 411 rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
 412 rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
 413                      ; return (wrapBinds floats body) }
 414
 415 --------
 416 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
 417 -- Remove top level lambdas by let-binding
 418
 419 rhsToBody (Note n expr)
 420         -- You can get things like
 421         --      case e of { p -> coerce t (\s -> ...) }
 422   = do { (floats, expr') <- rhsToBody expr
 423        ; return (floats, Note n expr') }
 424
 425 rhsToBody (Cast e co)
 426   = do { (floats, e') <- rhsToBody e
 427        ; return (floats, Cast e' co) }
 428
 429 rhsToBody expr@(Lam {})
 430   | Just no_lam_result <- tryEtaReduce bndrs body
 431   = return (emptyFloats, no_lam_result)
 432   | all isTyVar bndrs           -- Type lambdas are ok
 433   = return (emptyFloats, expr)
 434   | otherwise                   -- Some value lambdas
 435   = do { fn <- newVar (exprType expr)
 436        ; let rhs   = cpeEtaExpand (exprArity expr) expr
 437              float = FloatLet (NonRec fn rhs)
 438        ; return (unitFloat float, Var fn) }
 439   where
 440     (bndrs,body) = collectBinders expr
 441
 442 rhsToBody expr = return (emptyFloats, expr)
 443
 444
 445
 446 -- ---------------------------------------------------------------------------
 447 --              CpeApp: produces a result satisfying CpeApp
 448 -- ---------------------------------------------------------------------------
 449
 450 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 451 -- May return a CpeRhs because of saturating primops
 452 cpeApp env expr
 453   = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
 454        ; MASSERT(null ss)       -- make sure we used all the strictness info
 455
 456         -- Now deal with the function
 457        ; case head of
 458            Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
 459                            ; return (floats, sat_app) }
 460            _other    -> return (floats, app) }
 461
 462   where
 463     -- Deconstruct and rebuild the application, floating any non-atomic
 464     -- arguments to the outside.  We collect the type of the expression,
 465     -- the head of the application, and the number of actual value arguments,
 466     -- all of which are used to possibly saturate this application if it
 467     -- has a constructor or primop at the head.
 468
 469     collect_args
 470         :: CoreExpr
 471         -> Int                     -- Current app depth
 472         -> UniqSM (CpeApp,         -- The rebuilt expression
 473                    (CoreExpr,Int), -- The head of the application,
 474                                    -- and no. of args it was applied to
 475                    Type,           -- Type of the whole expr
 476                    Floats,         -- Any floats we pulled out
 477                    [Demand])       -- Remaining argument demands
 478
 479     collect_args (App fun arg@(Type arg_ty)) depth
 480       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
 481            ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
 482
 483     collect_args (App fun arg) depth
 484       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
 485            ; let
 486               (ss1, ss_rest)   = case ss of
 487                                    (ss1:ss_rest) -> (ss1,     ss_rest)
 488                                    []            -> (lazyDmd, [])
 489               (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
 490                                  splitFunTy_maybe fun_ty
 491
 492            ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty
 493            ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
 494
 495     collect_args (Var v) depth
 496       = do { v1 <- fiddleCCall v
 497            ; let v2 = lookupCorePrepEnv env v1
 498            ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
 499         where
 500           stricts = case idNewStrictness v of
 501                         StrictSig (DmdType _ demands _)
 502                             | listLengthCmp demands depth /= GT -> demands
 503                                     -- length demands <= depth
 504                             | otherwise                         -> []
 505                 -- If depth < length demands, then we have too few args to
 506                 -- satisfy strictness  info so we have to  ignore all the
 507                 -- strictness info, e.g. + (error "urk")
 508                 -- Here, we can't evaluate the arg strictly, because this
 509                 -- partial application might be seq'd
 510
 511     collect_args (Cast fun co) depth
 512       = do { let (_ty1,ty2) = coercionKind co
 513            ; (fun', hd, _, floats, ss) <- collect_args fun depth
 514            ; return (Cast fun' co, hd, ty2, floats, ss) }
 515
 516     collect_args (Note note fun) depth
 517       | ignoreNote note         -- Drop these notes altogether
 518       = collect_args fun depth  -- They aren't used by the code generator
 519
 520         -- N-variable fun, better let-bind it
 521     collect_args fun depth
 522       = do { (fun_floats, fun') <- cpeArg env True fun ty
 523                           -- The True says that it's sure to be evaluated,
 524                           -- so we'll end up case-binding it
 525            ; return (fun', (fun', depth), ty, fun_floats, []) }
 526         where
 527           ty = exprType fun
 528
 529 -- ---------------------------------------------------------------------------
 530 --      CpeArg: produces a result satisfying CpeArg
 531 -- ---------------------------------------------------------------------------
 532
 533 -- This is where we arrange that a non-trivial argument is let-bound
 534 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
 535        -> UniqSM (Floats, CpeTriv)
 536 cpeArg env is_strict arg arg_ty
 537   | cpe_ExprIsTrivial arg   -- Do not eta expand etc a trivial argument
 538   = cpeBody env arg         -- Must still do substitution though
 539   | otherwise
 540   = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
 541        ; (floats2, arg2) <- if want_float floats1 arg1
 542                             then return (floats1, arg1)
 543                             else do { body1 <- rhsToBodyNF arg1
 544                                     ; return (emptyFloats, wrapBinds floats1 body1) }
 545                 -- Else case: arg1 might have lambdas, and we can't
 546                 --            put them inside a wrapBinds
 547
 548        ; v <- newVar arg_ty
 549        ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
 550              arg_float = mkFloat is_strict is_unlifted v arg3
 551        ; return (addFloat floats2 arg_float, Var v) }
 552   where
 553     is_unlifted = isUnLiftedType arg_ty
 554     want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
 555 \end{code}
 556
 557 Note [Floating unlifted arguments]
 558 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 559 Consider    C (let v* = expensive in v)
 560
 561 where the "*" indicates "will be demanded".  Usually v will have been
 562 inlined by now, but let's suppose it hasn't (see Trac #2756).  Then we
 563 do *not* want to get
 564
 565      let v* = expensive in C v
 566
 567 because that has different strictness.  Hence the use of 'allLazy'.
 568 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
 569
 570
 571 ------------------------------------------------------------------------------
 572 -- Building the saturated syntax
 573 -- ---------------------------------------------------------------------------
 574
 575 maybeSaturate deals with saturating primops and constructors
 576 The type is the type of the entire application
 577
 578 \begin{code}
 579 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
 580 maybeSaturate fn expr n_args
 581   | Just DataToTagOp <- isPrimOpId_maybe fn     -- DataToTag must have an evaluated arg
 582                                                 -- A gruesome special case
 583   = saturateDataToTag sat_expr
 584
 585   | hasNoBinding fn        -- There's no binding
 586   = return sat_expr
 587
 588   | otherwise
 589   = return expr
 590   where
 591     fn_arity     = idArity fn
 592     excess_arity = fn_arity - n_args
 593     sat_expr     = cpeEtaExpand excess_arity expr
 594
 595 -------------
 596 saturateDataToTag :: CpeApp -> UniqSM CpeApp
 597 -- Horrid: ensure that the arg of data2TagOp is evaluated
 598 --   (data2tag x) -->  (case x of y -> data2tag y)
 599 -- (yuk yuk) take into account the lambdas we've now introduced
 600 saturateDataToTag sat_expr
 601   = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
 602        ; eta_body' <- eval_data2tag_arg eta_body
 603        ; return (mkLams eta_bndrs eta_body') }
 604   where
 605     eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
 606     eval_data2tag_arg app@(fun `App` arg)
 607         | exprIsHNF arg         -- Includes nullary constructors
 608         = return app            -- The arg is evaluated
 609         | otherwise                     -- Arg not evaluated, so evaluate it
 610         = do { arg_id <- newVar (exprType arg)
 611              ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
 612              ; return (Case arg arg_id1 (exprType app)
 613                             [(DEFAULT, [], fun `App` Var arg_id1)]) }
 614
 615     eval_data2tag_arg (Note note app)   -- Scc notes can appear
 616         = do { app' <- eval_data2tag_arg app
 617              ; return (Note note app') }
 618
 619     eval_data2tag_arg other     -- Should not happen
 620         = pprPanic "eval_data2tag" (ppr other)
 621 \end{code}
 622
 623
 624
 625
 626 %************************************************************************
 627 %*                                                                      *
 628                 Simple CoreSyn operations
 629 %*                                                                      *
 630 %************************************************************************
 631
 632 \begin{code}
 633         -- We don't ignore SCCs, since they require some code generation
 634 ignoreNote :: Note -> Bool
 635 -- Tells which notes to drop altogether; they are ignored by code generation
 636 -- Do not ignore SCCs!
 637 -- It's important that we do drop InlineMe notes; for example
 638 --    unzip = __inline_me__ (/\ab. foldr (..) (..))
 639 -- Here unzip gets arity 1 so we'll eta-expand it. But we don't
 640 -- want to get this:
 641 --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
 642 ignoreNote (CoreNote _) = True
 643 ignoreNote InlineMe     = True
 644 ignoreNote _other       = False
 645
 646
 647 cpe_ExprIsTrivial :: CoreExpr -> Bool
 648 -- Version that doesn't consider an scc annotation to be trivial.
 649 cpe_ExprIsTrivial (Var _)                  = True
 650 cpe_ExprIsTrivial (Type _)                 = True
 651 cpe_ExprIsTrivial (Lit _)                  = True
 652 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
 653 cpe_ExprIsTrivial (Note (SCC _) _)         = False
 654 cpe_ExprIsTrivial (Note _ e)               = cpe_ExprIsTrivial e
 655 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
 656 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
 657 cpe_ExprIsTrivial _                        = False
 658 \end{code}
 659
 660 -- -----------------------------------------------------------------------------
 661 --      Eta reduction
 662 -- -----------------------------------------------------------------------------
 663
 664 Note [Eta expansion]
 665 ~~~~~~~~~~~~~~~~~~~~~
 666 Eta expand to match the arity claimed by the binder Remember,
 667 CorePrep must not change arity
 668
 669 Eta expansion might not have happened already, because it is done by
 670 the simplifier only when there at least one lambda already.
 671
 672 NB1:we could refrain when the RHS is trivial (which can happen
 673     for exported things).  This would reduce the amount of code
 674     generated (a little) and make things a little words for
 675     code compiled without -O.  The case in point is data constructor
 676     wrappers.
 677
 678 NB2: we have to be careful that the result of etaExpand doesn't
 679    invalidate any of the assumptions that CorePrep is attempting
 680    to establish.  One possible cause is eta expanding inside of
 681    an SCC note - we're now careful in etaExpand to make sure the
 682    SCC is pushed inside any new lambdas that are generated.
 683
 684 Note [Eta expansion and the CorePrep invariants]
 685 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 686 It turns out to be much much easier to do eta expansion
 687 *after* the main CorePrep stuff.  But that places constraints
 688 on the eta expander: given a CpeRhs, it must return a CpeRhs.
 689
 690 For example here is what we do not want:
 691                 f = /\a -> g (h 3)      -- h has arity 2
 692 After ANFing we get
 693                 f = /\a -> let s = h 3 in g s
 694 and now we do NOT want eta expansion to give
 695                 f = /\a -> \ y -> (let s = h 3 in g s) y
 696
 697 Instead CoreArity.etaExpand gives
 698                 f = /\a -> \y -> let s = h 3 in g s y
 699
 700 \begin{code}
 701 cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr
 702 cpeEtaExpand arity expr
 703   | arity == 0 = expr
 704   | otherwise  = etaExpand arity expr
 705 \end{code}
 706
 707 -- -----------------------------------------------------------------------------
 708 --      Eta reduction
 709 -- -----------------------------------------------------------------------------
 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         case x of { p -> \xs. map f xs }
 716     ==> case x of { p -> map f }
 717
 718 \begin{code}
 719 tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
 720 tryEtaReduce 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 _    _         = 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 tryEtaReduce bndrs (Let bind@(NonRec _ r) body)
 741   | not (any (`elemVarSet` fvs) bndrs)
 742   = case tryEtaReduce bndrs body of
 743         Just e -> Just (Let bind e)
 744         Nothing -> Nothing
 745   where
 746     fvs = exprFreeVars r
 747
 748 tryEtaReduce _ _ = Nothing
 749 \end{code}
 750
 751
 752 -- -----------------------------------------------------------------------------
 753 -- Demands
 754 -- -----------------------------------------------------------------------------
 755
 756 \begin{code}
 757 type RhsDemand = Bool  -- True => used strictly; hence not top-level, non-recursive
 758 \end{code}
 759
 760 %************************************************************************
 761 %*                                                                      *
 762                 Floats
 763 %*                                                                      *
 764 %************************************************************************
 765
 766 \begin{code}
 767 data FloatingBind
 768   = FloatLet CoreBind           -- Rhs of bindings are CpeRhss
 769   | FloatCase Id CpeBody Bool   -- The bool indicates "ok-for-speculation"
 770
 771 data Floats = Floats OkToSpec (OrdList FloatingBind)
 772
 773 -- Can we float these binds out of the rhs of a let?  We cache this decision
 774 -- to avoid having to recompute it in a non-linear way when there are
 775 -- deeply nested lets.
 776 data OkToSpec
 777    = NotOkToSpec        -- definitely not
 778    | OkToSpec           -- yes
 779    | IfUnboxedOk        -- only if floating an unboxed binding is ok
 780
 781 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
 782 mkFloat is_strict is_unlifted bndr rhs
 783   | use_case  = FloatCase bndr rhs (exprOkForSpeculation rhs)
 784   | otherwise = FloatLet (NonRec bndr rhs)
 785   where
 786     use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
 787                 -- Don't make a case for a value binding,
 788                 -- even if it's strict.  Otherwise we get
 789                 --      case (\x -> e) of ...!
 790
 791 emptyFloats :: Floats
 792 emptyFloats = Floats OkToSpec nilOL
 793
 794 isEmptyFloats :: Floats -> Bool
 795 isEmptyFloats (Floats _ bs) = isNilOL bs
 796
 797 wrapBinds :: Floats -> CoreExpr -> CoreExpr
 798 wrapBinds (Floats _ binds) body
 799   = foldrOL mk_bind body binds
 800   where
 801     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
 802     mk_bind (FloatLet bind)        body = Let bind body
 803
 804 addFloat :: Floats -> FloatingBind -> Floats
 805 addFloat (Floats ok_to_spec floats) new_float
 806   = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
 807   where
 808     check (FloatLet _) = OkToSpec
 809     check (FloatCase _ _ ok_for_spec)
 810         | ok_for_spec  =  IfUnboxedOk
 811         | otherwise    =  NotOkToSpec
 812         -- The ok-for-speculation flag says that it's safe to
 813         -- float this Case out of a let, and thereby do it more eagerly
 814         -- We need the top-level flag because it's never ok to float
 815         -- an unboxed binding to the top level
 816
 817 unitFloat :: FloatingBind -> Floats
 818 unitFloat = addFloat emptyFloats
 819
 820 appendFloats :: Floats -> Floats -> Floats
 821 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
 822   = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
 823
 824 concatFloats :: [Floats] -> OrdList FloatingBind
 825 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
 826
 827 combine :: OkToSpec -> OkToSpec -> OkToSpec
 828 combine NotOkToSpec _ = NotOkToSpec
 829 combine _ NotOkToSpec = NotOkToSpec
 830 combine IfUnboxedOk _ = IfUnboxedOk
 831 combine _ IfUnboxedOk = IfUnboxedOk
 832 combine _ _           = OkToSpec
 833
 834 instance Outputable FloatingBind where
 835   ppr (FloatLet bind)        = text "FloatLet" <+> ppr bind
 836   ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
 837
 838 deFloatTop :: Floats -> [CoreBind]
 839 -- For top level only; we don't expect any FloatCases
 840 deFloatTop (Floats _ floats)
 841   = foldrOL get [] floats
 842   where
 843     get (FloatLet b) bs = b:bs
 844     get b            _  = pprPanic "corePrepPgm" (ppr b)
 845
 846 -------------------------------------------
 847 wantFloatTop :: Id -> Floats -> Bool
 848        -- Note [CafInfo and floating]
 849 wantFloatTop bndr floats = isEmptyFloats floats
 850                          || (mayHaveCafRefs (idCafInfo bndr)
 851                              && allLazyTop floats)
 852
 853 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
 854 wantFloatNested is_rec strict_or_unlifted floats rhs
 855   =  isEmptyFloats floats
 856   || strict_or_unlifted
 857   || (allLazyNested is_rec floats && exprIsHNF rhs)
 858         -- Why the test for allLazyNested?
 859         --      v = f (x `divInt#` y)
 860         -- we don't want to float the case, even if f has arity 2,
 861         -- because floating the case would make it evaluated too early
 862
 863 allLazyTop :: Floats -> Bool
 864 allLazyTop (Floats OkToSpec _) = True
 865 allLazyTop _                   = False
 866
 867 allLazyNested :: RecFlag -> Floats -> Bool
 868 allLazyNested _      (Floats OkToSpec    _) = True
 869 allLazyNested _      (Floats NotOkToSpec _) = False
 870 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
 871 \end{code}
 872
 873
 874 %************************************************************************
 875 %*                                                                      *
 876                 Cloning
 877 %*                                                                      *
 878 %************************************************************************
 879
 880 \begin{code}
 881 -- ---------------------------------------------------------------------------
 882 --                      The environment
 883 -- ---------------------------------------------------------------------------
 884
 885 data CorePrepEnv = CPE (IdEnv Id)       -- Clone local Ids
 886
 887 emptyCorePrepEnv :: CorePrepEnv
 888 emptyCorePrepEnv = CPE emptyVarEnv
 889
 890 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
 891 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
 892
 893 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
 894 extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
 895
 896 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
 897 lookupCorePrepEnv (CPE env) id
 898   = case lookupVarEnv env id of
 899         Nothing  -> id
 900         Just id' -> id'
 901
 902 ------------------------------------------------------------------------------
 903 -- Cloning binders
 904 -- ---------------------------------------------------------------------------
 905
 906 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
 907 cloneBndrs env bs = mapAccumLM cloneBndr env bs
 908
 909 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 910 cloneBndr env bndr
 911   | isLocalId bndr
 912   = do bndr' <- setVarUnique bndr <$> getUniqueM
 913        return (extendCorePrepEnv env bndr bndr', bndr')
 914
 915   | otherwise   -- Top level things, which we don't want
 916                 -- to clone, have become GlobalIds by now
 917                 -- And we don't clone tyvars
 918   = return (env, bndr)
 919
 920
 921 ------------------------------------------------------------------------------
 922 -- Cloning ccall Ids; each must have a unique name,
 923 -- to give the code generator a handle to hang it on
 924 -- ---------------------------------------------------------------------------
 925
 926 fiddleCCall :: Id -> UniqSM Id
 927 fiddleCCall id
 928   | isFCallId id = (id `setVarUnique`) <$> getUniqueM
 929   | otherwise    = return id
 930
 931 ------------------------------------------------------------------------------
 932 -- Generating new binders
 933 -- ---------------------------------------------------------------------------
 934
 935 newVar :: Type -> UniqSM Id
 936 newVar ty
 937  = seqType ty `seq` do
 938      uniq <- getUniqueM
 939      return (mkSysLocal (fsLit "sat") uniq ty)
 940 \end{code}