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