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