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 { (floats1, rhs1) <- cpeRhsE env rhs
 281        ; let (rhs1_bndrs, _) = collectBinders rhs1
 282        ; (floats2, rhs2)
 283             <- if want_float floats1 rhs1
 284                then return (floats1, rhs1)
 285                else -- Non-empty floats will wrap rhs1
 286                     -- But: rhs1 might have lambdas, and we can't
 287                     --      put them inside a wrapBinds
 288                if valBndrCount rhs1_bndrs <= arity
 289                then    -- Lambdas in rhs1 will be nuked by eta expansion
 290                     return (emptyFloats, wrapBinds floats1 rhs1)
 291
 292                else do { body1 <- rhsToBodyNF rhs1
 293                        ; return (emptyFloats, wrapBinds floats1 body1) }
 294
 295        ; (floats3, rhs')   -- Note [Silly extra arguments]
 296             <- if manifestArity rhs2 <= arity
 297                then return (floats2, cpeEtaExpand arity rhs2)
 298                else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
 299                     (do { v <- newVar (idType bndr)
 300                         ; let float = mkFloat False False v rhs2
 301                         ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
 302
 303                 -- Record if the binder is evaluated
 304        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
 305                    | otherwise      = bndr
 306
 307        ; return (floats3, bndr', rhs') }
 308   where
 309     arity = idArity bndr        -- We must match this arity
 310     want_float floats rhs
 311      | isTopLevel top_lvl = wantFloatTop bndr floats
 312      | otherwise          = wantFloatNested is_rec is_strict_or_unlifted floats rhs
 313
 314 {- Note [Silly extra arguments]
 315 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 316 Suppose we had this
 317         f{arity=1} = \x\y. e
 318 We *must* match the arity on the Id, so we have to generate
 319         f' = \x\y. e
 320         f  = \x. f' x
 321
 322 It's a bizarre case: why is the arity on the Id wrong?  Reason
 323 (in the days of __inline_me__):
 324         f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
 325 When InlineMe notes go away this won't happen any more.  But
 326 it seems good for CorePrep to be robust.
 327 -}
 328
 329 -- ---------------------------------------------------------------------------
 330 --              CpeRhs: produces a result satisfying CpeRhs
 331 -- ---------------------------------------------------------------------------
 332
 333 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 334 -- If
 335 --      e  ===>  (bs, e')
 336 -- then
 337 --      e = let bs in e'        (semantically, that is!)
 338 --
 339 -- For example
 340 --      f (g x)   ===>   ([v = g x], f v)
 341
 342 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
 343 cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)
 344 cpeRhsE env expr@(App {})  = cpeApp env expr
 345 cpeRhsE env expr@(Var {})  = cpeApp env expr
 346
 347 cpeRhsE env (Let bind expr)
 348   = do { (env', new_binds) <- cpeBind NotTopLevel env bind
 349        ; (floats, body) <- cpeRhsE env' expr
 350        ; return (new_binds `appendFloats` floats, body) }
 351
 352 cpeRhsE env (Note note expr)
 353   | ignoreNote note
 354   = cpeRhsE env expr
 355   | otherwise         -- Just SCCs actually
 356   = do { body <- cpeBodyNF env expr
 357        ; return (emptyFloats, Note note body) }
 358
 359 cpeRhsE env (Cast expr co)
 360    = do { (floats, expr') <- cpeRhsE env expr
 361         ; return (floats, Cast expr' co) }
 362
 363 cpeRhsE env expr@(Lam {})
 364    = do { let (bndrs,body) = collectBinders expr
 365         ; (env', bndrs') <- cloneBndrs env bndrs
 366         ; body' <- cpeBodyNF env' body
 367         ; return (emptyFloats, mkLams bndrs' body') }
 368
 369 cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
 370   | Just (TickBox {}) <- isTickBoxOp_maybe id
 371   = do { body <- cpeBodyNF env expr
 372        ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) }
 373
 374 cpeRhsE env (Case scrut bndr ty alts)
 375   = do { (floats, scrut') <- cpeBody env scrut
 376        ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
 377             -- Record that the case binder is evaluated in the alternatives
 378        ; (env', bndr2) <- cloneBndr env bndr1
 379        ; alts' <- mapM (sat_alt env') alts
 380        ; return (floats, Case scrut' bndr2 ty alts') }
 381   where
 382     sat_alt env (con, bs, rhs)
 383        = do { (env2, bs') <- cloneBndrs env bs
 384             ; rhs' <- cpeBodyNF env2 rhs
 385             ; return (con, bs', rhs') }
 386
 387 -- ---------------------------------------------------------------------------
 388 --              CpeBody: produces a result satisfying CpeBody
 389 -- ---------------------------------------------------------------------------
 390
 391 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
 392 cpeBodyNF env expr
 393   = do { (floats, body) <- cpeBody env expr
 394        ; return (wrapBinds floats body) }
 395
 396 --------
 397 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
 398 cpeBody env expr
 399   = do { (floats1, rhs) <- cpeRhsE env expr
 400        ; (floats2, body) <- rhsToBody rhs
 401        ; return (floats1 `appendFloats` floats2, body) }
 402
 403 --------
 404 rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
 405 rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
 406                      ; return (wrapBinds floats body) }
 407
 408 --------
 409 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
 410 -- Remove top level lambdas by let-bindinig
 411
 412 rhsToBody (Note n expr)
 413         -- You can get things like
 414         --      case e of { p -> coerce t (\s -> ...) }
 415   = do { (floats, expr') <- rhsToBody expr
 416        ; return (floats, Note n expr') }
 417
 418 rhsToBody (Cast e co)
 419   = do { (floats, e') <- rhsToBody e
 420        ; return (floats, Cast e' co) }
 421
 422 rhsToBody expr@(Lam {})
 423   | Just no_lam_result <- tryEtaReduce bndrs body
 424   = return (emptyFloats, no_lam_result)
 425   | all isTyVar bndrs           -- Type lambdas are ok
 426   = return (emptyFloats, expr)
 427   | otherwise                   -- Some value lambdas
 428   = do { fn <- newVar (exprType expr)
 429        ; let rhs   = cpeEtaExpand (exprArity expr) expr
 430              float = FloatLet (NonRec fn rhs)
 431        ; return (unitFloat float, Var fn) }
 432   where
 433     (bndrs,body) = collectBinders expr
 434
 435 rhsToBody expr = return (emptyFloats, expr)
 436
 437
 438
 439 -- ---------------------------------------------------------------------------
 440 --              CpeApp: produces a result satisfying CpeApp
 441 -- ---------------------------------------------------------------------------
 442
 443 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 444 -- May return a CpeRhs because of saturating primops
 445 cpeApp env expr
 446   = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
 447        ; MASSERT(null ss)       -- make sure we used all the strictness info
 448
 449         -- Now deal with the function
 450        ; case head of
 451            Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
 452                            ; return (floats, sat_app) }
 453            _other    -> return (floats, app) }
 454
 455   where
 456     -- Deconstruct and rebuild the application, floating any non-atomic
 457     -- arguments to the outside.  We collect the type of the expression,
 458     -- the head of the application, and the number of actual value arguments,
 459     -- all of which are used to possibly saturate this application if it
 460     -- has a constructor or primop at the head.
 461
 462     collect_args
 463         :: CoreExpr
 464         -> Int                     -- Current app depth
 465         -> UniqSM (CpeApp,         -- The rebuilt expression
 466                    (CoreExpr,Int), -- The head of the application,
 467                                    -- and no. of args it was applied to
 468                    Type,           -- Type of the whole expr
 469                    Floats,         -- Any floats we pulled out
 470                    [Demand])       -- Remaining argument demands
 471
 472     collect_args (App fun arg@(Type arg_ty)) depth
 473       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
 474            ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
 475
 476     collect_args (App fun arg) depth
 477       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
 478            ; let
 479               (ss1, ss_rest)   = case ss of
 480                                    (ss1:ss_rest) -> (ss1,     ss_rest)
 481                                    []            -> (lazyDmd, [])
 482               (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
 483                                  splitFunTy_maybe fun_ty
 484
 485            ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty
 486            ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
 487
 488     collect_args (Var v) depth
 489       = do { v1 <- fiddleCCall v
 490            ; let v2 = lookupCorePrepEnv env v1
 491            ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
 492         where
 493           stricts = case idNewStrictness v of
 494                         StrictSig (DmdType _ demands _)
 495                             | listLengthCmp demands depth /= GT -> demands
 496                                     -- length demands <= depth
 497                             | otherwise                         -> []
 498                 -- If depth < length demands, then we have too few args to
 499                 -- satisfy strictness  info so we have to  ignore all the
 500                 -- strictness info, e.g. + (error "urk")
 501                 -- Here, we can't evaluate the arg strictly, because this
 502                 -- partial application might be seq'd
 503
 504     collect_args (Cast fun co) depth
 505       = do { let (_ty1,ty2) = coercionKind co
 506            ; (fun', hd, _, floats, ss) <- collect_args fun depth
 507            ; return (Cast fun' co, hd, ty2, floats, ss) }
 508
 509     collect_args (Note note fun) depth
 510       | ignoreNote note         -- Drop these notes altogether
 511       = collect_args fun depth  -- They aren't used by the code generator
 512
 513         -- N-variable fun, better let-bind it
 514         -- ToDo: perhaps we can case-bind rather than let-bind this closure,
 515         -- since it is sure to be evaluated.
 516     collect_args fun depth
 517       = do { (fun_floats, fun') <- cpeArg env True fun ty
 518            ; return (fun', (fun', depth), ty, fun_floats, []) }
 519         where
 520           ty = exprType fun
 521
 522 -- ---------------------------------------------------------------------------
 523 --      CpeArg: produces a result satisfying CpeArg
 524 -- ---------------------------------------------------------------------------
 525
 526 -- This is where we arrange that a non-trivial argument is let-bound
 527 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
 528        -> UniqSM (Floats, CpeTriv)
 529 cpeArg env is_strict arg arg_ty
 530   | cpe_ExprIsTrivial arg   -- Do not eta expand etc a trivial argument
 531   = cpeBody env arg         -- Must still do substitution though
 532   | otherwise
 533   = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
 534        ; (floats2, arg2) <- if want_float floats1 arg1
 535                             then return (floats1, arg1)
 536                             else do { body1 <- rhsToBodyNF arg1
 537                                     ; return (emptyFloats, wrapBinds floats1 body1) }
 538                 -- Else case: arg1 might have lambdas, and we can't
 539                 --            put them inside a wrapBinds
 540
 541        ; v <- newVar arg_ty
 542        ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
 543              arg_float = mkFloat is_strict is_unlifted v arg3
 544        ; return (addFloat floats2 arg_float, Var v) }
 545   where
 546     is_unlifted = isUnLiftedType arg_ty
 547     want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
 548 \end{code}
 549
 550 Note [Floating unlifted arguments]
 551 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 552 Consider    C (let v* = expensive in v)
 553
 554 where the "*" indicates "will be demanded".  Usually v will have been
 555 inlined by now, but let's suppose it hasn't (see Trac #2756).  Then we
 556 do *not* want to get
 557
 558      let v* = expensive in C v
 559
 560 because that has different strictness.  Hence the use of 'allLazy'.
 561 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
 562
 563
 564 ------------------------------------------------------------------------------
 565 -- Building the saturated syntax
 566 -- ---------------------------------------------------------------------------
 567
 568 maybeSaturate deals with saturating primops and constructors
 569 The type is the type of the entire application
 570
 571 \begin{code}
 572 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
 573 maybeSaturate fn expr n_args
 574   | Just DataToTagOp <- isPrimOpId_maybe fn     -- DataToTag must have an evaluated arg
 575                                                 -- A gruesome special case
 576   = saturateDataToTag sat_expr
 577
 578   | hasNoBinding fn        -- There's no binding
 579   = return sat_expr
 580
 581   | otherwise
 582   = return expr
 583   where
 584     fn_arity     = idArity fn
 585     excess_arity = fn_arity - n_args
 586     sat_expr     = cpeEtaExpand excess_arity expr
 587
 588 -------------
 589 saturateDataToTag :: CpeApp -> UniqSM CpeApp
 590 -- Horrid: ensure that the arg of data2TagOp is evaluated
 591 --   (data2tag x) -->  (case x of y -> data2tag y)
 592 -- (yuk yuk) take into account the lambdas we've now introduced
 593 saturateDataToTag sat_expr
 594   = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
 595        ; eta_body' <- eval_data2tag_arg eta_body
 596        ; return (mkLams eta_bndrs eta_body') }
 597   where
 598     eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
 599     eval_data2tag_arg app@(fun `App` arg)
 600         | exprIsHNF arg         -- Includes nullary constructors
 601         = return app            -- The arg is evaluated
 602         | otherwise                     -- Arg not evaluated, so evaluate it
 603         = do { arg_id <- newVar (exprType arg)
 604              ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
 605              ; return (Case arg arg_id1 (exprType app)
 606                             [(DEFAULT, [], fun `App` Var arg_id1)]) }
 607
 608     eval_data2tag_arg (Note note app)   -- Scc notes can appear
 609         = do { app' <- eval_data2tag_arg app
 610              ; return (Note note app') }
 611
 612     eval_data2tag_arg other     -- Should not happen
 613         = pprPanic "eval_data2tag" (ppr other)
 614 \end{code}
 615
 616
 617
 618
 619 %************************************************************************
 620 %*                                                                      *
 621                 Simple CoreSyn operations
 622 %*                                                                      *
 623 %************************************************************************
 624
 625 \begin{code}
 626         -- We don't ignore SCCs, since they require some code generation
 627 ignoreNote :: Note -> Bool
 628 -- Tells which notes to drop altogether; they are ignored by code generation
 629 -- Do not ignore SCCs!
 630 -- It's important that we do drop InlineMe notes; for example
 631 --    unzip = __inline_me__ (/\ab. foldr (..) (..))
 632 -- Here unzip gets arity 1 so we'll eta-expand it. But we don't
 633 -- want to get this:
 634 --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
 635 ignoreNote (CoreNote _) = True
 636 ignoreNote InlineMe     = True
 637 ignoreNote _other       = False
 638
 639
 640 cpe_ExprIsTrivial :: CoreExpr -> Bool
 641 -- Version that doesn't consider an scc annotation to be trivial.
 642 cpe_ExprIsTrivial (Var _)                  = True
 643 cpe_ExprIsTrivial (Type _)                 = True
 644 cpe_ExprIsTrivial (Lit _)                  = True
 645 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
 646 cpe_ExprIsTrivial (Note (SCC _) _)         = False
 647 cpe_ExprIsTrivial (Note _ e)               = cpe_ExprIsTrivial e
 648 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
 649 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
 650 cpe_ExprIsTrivial _                        = False
 651 \end{code}
 652
 653 -- -----------------------------------------------------------------------------
 654 --      Eta reduction
 655 -- -----------------------------------------------------------------------------
 656
 657 Note [Eta expansion]
 658 ~~~~~~~~~~~~~~~~~~~~~
 659 Eta expand to match the arity claimed by the binder Remember,
 660 CorePrep must not change arity
 661
 662 Eta expansion might not have happened already, because it is done by
 663 the simplifier only when there at least one lambda already.
 664
 665 NB1:we could refrain when the RHS is trivial (which can happen
 666     for exported things).  This would reduce the amount of code
 667     generated (a little) and make things a little words for
 668     code compiled without -O.  The case in point is data constructor
 669     wrappers.
 670
 671 NB2: we have to be careful that the result of etaExpand doesn't
 672    invalidate any of the assumptions that CorePrep is attempting
 673    to establish.  One possible cause is eta expanding inside of
 674    an SCC note - we're now careful in etaExpand to make sure the
 675    SCC is pushed inside any new lambdas that are generated.
 676
 677 Note [Eta expansion and the CorePrep invariants]
 678 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 679 It turns out to be much much easier to do eta expansion
 680 *after* the main CorePrep stuff.  But that places constraints
 681 on the eta expander: given a CpeRhs, it must return a CpeRhs.
 682
 683 For example here is what we do not want:
 684                 f = /\a -> g (h 3)      -- h has arity 2
 685 After ANFing we get
 686                 f = /\a -> let s = h 3 in g s
 687 and now we do NOT want eta expansion to give
 688                 f = /\a -> \ y -> (let s = h 3 in g s) y
 689
 690 Instead CoreArity.etaExpand gives
 691                 f = /\a -> \y -> let s = h 3 in g s y
 692
 693 \begin{code}
 694 cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr
 695 cpeEtaExpand arity expr
 696   | arity == 0 = expr
 697   | otherwise  = etaExpand arity expr
 698 \end{code}
 699
 700 -- -----------------------------------------------------------------------------
 701 --      Eta reduction
 702 -- -----------------------------------------------------------------------------
 703
 704 Why try eta reduction?  Hasn't the simplifier already done eta?
 705 But the simplifier only eta reduces if that leaves something
 706 trivial (like f, or f Int).  But for deLam it would be enough to
 707 get to a partial application:
 708         case x of { p -> \xs. map f xs }
 709     ==> case x of { p -> map f }
 710
 711 \begin{code}
 712 tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
 713 tryEtaReduce bndrs expr@(App _ _)
 714   | ok_to_eta_reduce f &&
 715     n_remaining >= 0 &&
 716     and (zipWith ok bndrs last_args) &&
 717     not (any (`elemVarSet` fvs_remaining) bndrs)
 718   = Just remaining_expr
 719   where
 720     (f, args) = collectArgs expr
 721     remaining_expr = mkApps f remaining_args
 722     fvs_remaining = exprFreeVars remaining_expr
 723     (remaining_args, last_args) = splitAt n_remaining args
 724     n_remaining = length args - length bndrs
 725
 726     ok bndr (Var arg) = bndr == arg
 727     ok _    _         = False
 728
 729           -- we can't eta reduce something which must be saturated.
 730     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 731     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 732
 733 tryEtaReduce bndrs (Let bind@(NonRec _ r) body)
 734   | not (any (`elemVarSet` fvs) bndrs)
 735   = case tryEtaReduce bndrs body of
 736         Just e -> Just (Let bind e)
 737         Nothing -> Nothing
 738   where
 739     fvs = exprFreeVars r
 740
 741 tryEtaReduce _ _ = Nothing
 742 \end{code}
 743
 744
 745 -- -----------------------------------------------------------------------------
 746 -- Demands
 747 -- -----------------------------------------------------------------------------
 748
 749 \begin{code}
 750 type RhsDemand = Bool  -- True => used strictly; hence not top-level, non-recursive
 751 \end{code}
 752
 753 %************************************************************************
 754 %*                                                                      *
 755                 Floats
 756 %*                                                                      *
 757 %************************************************************************
 758
 759 \begin{code}
 760 data FloatingBind
 761   = FloatLet CoreBind           -- Rhs of bindings are CpeRhss
 762   | FloatCase Id CpeBody Bool   -- The bool indicates "ok-for-speculation"
 763
 764 data Floats = Floats OkToSpec (OrdList FloatingBind)
 765
 766 -- Can we float these binds out of the rhs of a let?  We cache this decision
 767 -- to avoid having to recompute it in a non-linear way when there are
 768 -- deeply nested lets.
 769 data OkToSpec
 770    = NotOkToSpec        -- definitely not
 771    | OkToSpec           -- yes
 772    | IfUnboxedOk        -- only if floating an unboxed binding is ok
 773
 774 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
 775 mkFloat is_strict is_unlifted bndr rhs
 776   | use_case  = FloatCase bndr rhs (exprOkForSpeculation rhs)
 777   | otherwise = FloatLet (NonRec bndr rhs)
 778   where
 779     use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
 780                 -- Don't make a case for a value binding,
 781                 -- even if it's strict.  Otherwise we get
 782                 --      case (\x -> e) of ...!
 783
 784 emptyFloats :: Floats
 785 emptyFloats = Floats OkToSpec nilOL
 786
 787 isEmptyFloats :: Floats -> Bool
 788 isEmptyFloats (Floats _ bs) = isNilOL bs
 789
 790 wrapBinds :: Floats -> CoreExpr -> CoreExpr
 791 wrapBinds (Floats _ binds) body
 792   = foldrOL mk_bind body binds
 793   where
 794     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
 795     mk_bind (FloatLet bind)        body = Let bind body
 796
 797 addFloat :: Floats -> FloatingBind -> Floats
 798 addFloat (Floats ok_to_spec floats) new_float
 799   = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
 800   where
 801     check (FloatLet _) = OkToSpec
 802     check (FloatCase _ _ ok_for_spec)
 803         | ok_for_spec  =  IfUnboxedOk
 804         | otherwise    =  NotOkToSpec
 805         -- The ok-for-speculation flag says that it's safe to
 806         -- float this Case out of a let, and thereby do it more eagerly
 807         -- We need the top-level flag because it's never ok to float
 808         -- an unboxed binding to the top level
 809
 810 unitFloat :: FloatingBind -> Floats
 811 unitFloat = addFloat emptyFloats
 812
 813 appendFloats :: Floats -> Floats -> Floats
 814 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
 815   = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
 816
 817 concatFloats :: [Floats] -> OrdList FloatingBind
 818 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
 819
 820 combine :: OkToSpec -> OkToSpec -> OkToSpec
 821 combine NotOkToSpec _ = NotOkToSpec
 822 combine _ NotOkToSpec = NotOkToSpec
 823 combine IfUnboxedOk _ = IfUnboxedOk
 824 combine _ IfUnboxedOk = IfUnboxedOk
 825 combine _ _           = OkToSpec
 826
 827 instance Outputable FloatingBind where
 828   ppr (FloatLet bind)        = text "FloatLet" <+> ppr bind
 829   ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
 830
 831 deFloatTop :: Floats -> [CoreBind]
 832 -- For top level only; we don't expect any FloatCases
 833 deFloatTop (Floats _ floats)
 834   = foldrOL get [] floats
 835   where
 836     get (FloatLet b) bs = b:bs
 837     get b            _  = pprPanic "corePrepPgm" (ppr b)
 838
 839 -------------------------------------------
 840 wantFloatTop :: Id -> Floats -> Bool
 841        -- Note [CafInfo and floating]
 842 wantFloatTop bndr floats = isEmptyFloats floats
 843                          || (mayHaveCafRefs (idCafInfo bndr)
 844                              && allLazyTop floats)
 845
 846 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
 847 wantFloatNested is_rec strict_or_unlifted floats rhs
 848   =  isEmptyFloats floats
 849   || strict_or_unlifted
 850   || (allLazyNested is_rec floats && exprIsHNF rhs)
 851         -- Why the test for allLazyNested?
 852         --      v = f (x `divInt#` y)
 853         -- we don't want to float the case, even if f has arity 2,
 854         -- because floating the case would make it evaluated too early
 855
 856 allLazyTop :: Floats -> Bool
 857 allLazyTop (Floats OkToSpec _) = True
 858 allLazyTop _                   = False
 859
 860 allLazyNested :: RecFlag -> Floats -> Bool
 861 allLazyNested _      (Floats OkToSpec    _) = True
 862 allLazyNested _      (Floats NotOkToSpec _) = False
 863 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
 864 \end{code}
 865
 866
 867 %************************************************************************
 868 %*                                                                      *
 869                 Cloning
 870 %*                                                                      *
 871 %************************************************************************
 872
 873 \begin{code}
 874 -- ---------------------------------------------------------------------------
 875 --                      The environment
 876 -- ---------------------------------------------------------------------------
 877
 878 data CorePrepEnv = CPE (IdEnv Id)       -- Clone local Ids
 879
 880 emptyCorePrepEnv :: CorePrepEnv
 881 emptyCorePrepEnv = CPE emptyVarEnv
 882
 883 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
 884 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
 885
 886 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
 887 extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
 888
 889 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
 890 lookupCorePrepEnv (CPE env) id
 891   = case lookupVarEnv env id of
 892         Nothing  -> id
 893         Just id' -> id'
 894
 895 ------------------------------------------------------------------------------
 896 -- Cloning binders
 897 -- ---------------------------------------------------------------------------
 898
 899 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
 900 cloneBndrs env bs = mapAccumLM cloneBndr env bs
 901
 902 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 903 cloneBndr env bndr
 904   | isLocalId bndr
 905   = do bndr' <- setVarUnique bndr <$> getUniqueM
 906        return (extendCorePrepEnv env bndr bndr', bndr')
 907
 908   | otherwise   -- Top level things, which we don't want
 909                 -- to clone, have become GlobalIds by now
 910                 -- And we don't clone tyvars
 911   = return (env, bndr)
 912
 913
 914 ------------------------------------------------------------------------------
 915 -- Cloning ccall Ids; each must have a unique name,
 916 -- to give the code generator a handle to hang it on
 917 -- ---------------------------------------------------------------------------
 918
 919 fiddleCCall :: Id -> UniqSM Id
 920 fiddleCCall id
 921   | isFCallId id = (id `setVarUnique`) <$> getUniqueM
 922   | otherwise    = return id
 923
 924 ------------------------------------------------------------------------------
 925 -- Generating new binders
 926 -- ---------------------------------------------------------------------------
 927
 928 newVar :: Type -> UniqSM Id
 929 newVar ty
 930  = seqType ty `seq` do
 931      uniq <- getUniqueM
 932      return (mkSysLocal (fsLit "sat") uniq ty)
 933 \end{code}