ghc/compiler/coreSyn/CorePrep.lhs

   1 %
   2 % (c) The University of Glasgow, 1994-2000
   3 %
   4 \section{Core pass to saturate constructors and PrimOps}
   5
   6 \begin{code}
   7 module CorePrep (
   8       corePrepPgm, corePrepExpr
   9   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
  14 import CoreFVs  ( exprFreeVars )
  15 import CoreLint ( endPass )
  16 import CoreSyn
  17 import Type     ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
  18                   isUnLiftedType, isUnboxedTupleType, repType,
  19                   uaUTy, usOnce, usMany, eqUsage, seqType )
  20 import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
  21 import PrimOp   ( PrimOp(..) )
  22 import Var      ( Var, Id, setVarUnique )
  23 import VarSet
  24 import VarEnv
  25 import Id       ( mkSysLocal, idType, idNewDemandInfo, idArity,
  26                   setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
  27                   isLocalId, hasNoBinding, idNewStrictness,
  28                   isDataConId_maybe, idUnfolding
  29                 )
  30 import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
  31 import Unique   ( mkBuiltinUnique )
  32 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
  33                     RecFlag(..), isNonRec
  34                   )
  35 import UniqSupply
  36 import Maybes
  37 import OrdList
  38 import ErrUtils
  39 import CmdLineOpts
  40 import Util       ( listLengthCmp )
  41 import Outputable
  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:
  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 lambdas only occur as the RHS of a binding
  67     (The code generator can't deal with anything else.)
  68
  69 5.  Do the seq/par munging.  See notes with mkCase below.
  70
  71 6.  Clone all local Ids.
  72     This means that all such Ids are unique, rather than the
  73     weaker guarantee of no clashes which the simplifier provides.
  74     And that is what the code generator needs.
  75
  76     We don't clone TyVars. The code gen doesn't need that,
  77     and doing so would be tiresome because then we'd need
  78     to substitute in types.
  79
  80
  81 7.  Give each dynamic CCall occurrence a fresh unique; this is
  82     rather like the cloning step above.
  83
  84 8.  Inject bindings for the "implicit" Ids:
  85         * Constructor wrappers
  86         * Constructor workers
  87         * Record selectors
  88     We want curried definitions for all of these in case they
  89     aren't inlined by some caller.
  90
  91 This is all done modulo type applications and abstractions, so that
  92 when type erasure is done for conversion to STG, we don't end up with
  93 any trivial or useless bindings.
  94
  95
  96
  97 -- -----------------------------------------------------------------------------
  98 -- Top level stuff
  99 -- -----------------------------------------------------------------------------
 100
 101 \begin{code}
 102 corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
 103 corePrepPgm dflags mod_details
 104   = do  showPass dflags "CorePrep"
 105         us <- mkSplitUniqSupply 's'
 106
 107         let implicit_binds = mkImplicitBinds (md_types mod_details)
 108                 -- NB: we must feed mkImplicitBinds through corePrep too
 109                 -- so that they are suitably cloned and eta-expanded
 110
 111             binds_out = initUs_ us (
 112                           corePrepTopBinds (md_binds mod_details)       `thenUs` \ floats1 ->
 113                           corePrepTopBinds implicit_binds               `thenUs` \ floats2 ->
 114                           returnUs (deFloatTop (floats1 `appOL` floats2))
 115                         )
 116
 117         endPass dflags "CorePrep" Opt_D_dump_prep binds_out
 118         return (mod_details { md_binds = binds_out })
 119
 120 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 121 corePrepExpr dflags expr
 122   = do showPass dflags "CorePrep"
 123        us <- mkSplitUniqSupply 's'
 124        let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
 125        dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
 126                      (ppr new_expr)
 127        return new_expr
 128 \end{code}
 129
 130 -- -----------------------------------------------------------------------------
 131 -- Implicit bindings
 132 -- -----------------------------------------------------------------------------
 133
 134 Create any necessary "implicit" bindings (data constructors etc).
 135 Namely:
 136         * Constructor workers
 137         * Constructor wrappers
 138         * Data type record selectors
 139         * Class op selectors
 140
 141 In the latter three cases, the Id contains the unfolding to use for
 142 the binding.  In the case of data con workers we create the rather
 143 strange (non-recursive!) binding
 144
 145         $wC = \x y -> $wC x y
 146
 147 i.e. a curried constructor that allocates.  This means that we can
 148 treat the worker for a constructor like any other function in the rest
 149 of the compiler.  The point here is that CoreToStg will generate a
 150 StgConApp for the RHS, rather than a call to the worker (which would
 151 give a loop).  As Lennart says: the ice is thin here, but it works.
 152
 153 Hmm.  Should we create bindings for dictionary constructors?  They are
 154 always fully applied, and the bindings are just there to support
 155 partial applications. But it's easier to let them through.
 156
 157 \begin{code}
 158 mkImplicitBinds type_env
 159   = [ NonRec id (get_unfolding id)
 160     | id <- implicitTyThingIds (typeEnvElts type_env) ]
 161         -- The etaExpand is so that the manifest arity of the
 162         -- binding matches its claimed arity, which is an
 163         -- invariant of top level bindings going into the code gen
 164   where
 165     tmpl_uniqs = map mkBuiltinUnique [1..]
 166
 167 get_unfolding id        -- See notes above
 168   | Just data_con <- isDataConId_maybe id = Var id      -- The ice is thin here, but it works
 169   | otherwise                             = unfoldingTemplate (idUnfolding id)
 170 \end{code}
 171
 172
 173 \begin{code}
 174 -- ---------------------------------------------------------------------------
 175 -- Dealing with bindings
 176 -- ---------------------------------------------------------------------------
 177
 178 data FloatingBind = FloatLet CoreBind
 179                   | FloatCase Id CoreExpr Bool
 180                         -- The bool indicates "ok-for-speculation"
 181
 182 instance Outputable FloatingBind where
 183   ppr (FloatLet bind)        = text "FloatLet" <+> ppr bind
 184   ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
 185
 186 type CloneEnv = IdEnv Id        -- Clone local Ids
 187
 188 deFloatTop :: OrdList FloatingBind -> [CoreBind]
 189 -- For top level only; we don't expect any FloatCases
 190 deFloatTop floats
 191   = foldrOL get [] floats
 192   where
 193     get (FloatLet b) bs = b:bs
 194     get b            bs = pprPanic "corePrepPgm" (ppr b)
 195
 196 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
 197 allLazy top_lvl is_rec floats
 198   = foldrOL check True floats
 199   where
 200     unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
 201
 202     check (FloatLet _)                y = y
 203     check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
 204         -- The ok-for-speculation flag says that it's safe to
 205         -- float this Case out of a let, and thereby do it more eagerly
 206         -- We need the top-level flag because it's never ok to float
 207         -- an unboxed binding to the top level
 208
 209 -- ---------------------------------------------------------------------------
 210 --                      Bindings
 211 -- ---------------------------------------------------------------------------
 212
 213 corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
 214 corePrepTopBinds binds
 215   = go emptyVarEnv binds
 216   where
 217     go env []             = returnUs nilOL
 218     go env (bind : binds) = corePrepTopBind env bind    `thenUs` \ (env', bind') ->
 219                             go env' binds               `thenUs` \ binds' ->
 220                             returnUs (bind' `appOL` binds')
 221
 222 -- NB: we do need to float out of top-level bindings
 223 -- Consider     x = length [True,False]
 224 -- We want to get
 225 --              s1 = False : []
 226 --              s2 = True  : s1
 227 --              x  = length s2
 228
 229 -- We return a *list* of bindings, because we may start with
 230 --      x* = f (g y)
 231 -- where x is demanded, in which case we want to finish with
 232 --      a = g y
 233 --      x* = f a
 234 -- And then x will actually end up case-bound
 235
 236 --------------------------------
 237 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 238 corePrepTopBind env (NonRec bndr rhs)
 239   = cloneBndr env bndr                                  `thenUs` \ (env', bndr') ->
 240     corePrepRhs TopLevel NonRecursive env (bndr, rhs)   `thenUs` \ (floats, rhs') ->
 241     returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
 242
 243 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
 244
 245 --------------------------------
 246 corePrepBind ::  CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 247         -- This one is used for *local* bindings
 248 corePrepBind env (NonRec bndr rhs)
 249   = etaExpandRhs bndr rhs                               `thenUs` \ rhs1 ->
 250     corePrepExprFloat env rhs1                          `thenUs` \ (floats, rhs2) ->
 251     cloneBndr env bndr                                  `thenUs` \ (env', bndr') ->
 252     mkLocalNonRec bndr' (bdrDem bndr') floats rhs2      `thenUs` \ floats' ->
 253     returnUs (env', floats')
 254
 255 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
 256
 257 --------------------------------
 258 corePrepRecPairs :: TopLevelFlag -> CloneEnv
 259                  -> [(Id,CoreExpr)]     -- Recursive bindings
 260                  -> UniqSM (CloneEnv, OrdList FloatingBind)
 261 -- Used for all recursive bindings, top level and otherwise
 262 corePrepRecPairs lvl env pairs
 263   = cloneBndrs env (map fst pairs)                              `thenUs` \ (env', bndrs') ->
 264     mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs        `thenUs` \ (floats_s, rhss') ->
 265     returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
 266   where
 267         -- Flatten all the floats, and the currrent
 268         -- group into a single giant Rec
 269     flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
 270
 271     get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
 272     get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
 273
 274 --------------------------------
 275 corePrepRhs :: TopLevelFlag -> RecFlag
 276             -> CloneEnv -> (Id, CoreExpr)
 277             -> UniqSM (OrdList FloatingBind, CoreExpr)
 278 -- Used for top-level bindings, and local recursive bindings
 279 corePrepRhs top_lvl is_rec env (bndr, rhs)
 280   = etaExpandRhs bndr rhs       `thenUs` \ rhs' ->
 281     corePrepExprFloat env rhs'  `thenUs` \ floats_w_rhs ->
 282     floatRhs top_lvl is_rec bndr floats_w_rhs
 283
 284
 285 -- ---------------------------------------------------------------------------
 286 -- Making arguments atomic (function args & constructor args)
 287 -- ---------------------------------------------------------------------------
 288
 289 -- This is where we arrange that a non-trivial argument is let-bound
 290 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
 291            -> UniqSM (OrdList FloatingBind, CoreArg)
 292 corePrepArg env arg dem
 293   = corePrepExprFloat env arg           `thenUs` \ (floats, arg') ->
 294     if exprIsTrivial arg'
 295     then returnUs (floats, arg')
 296     else newVar (exprType arg')                 `thenUs` \ v ->
 297          mkLocalNonRec v dem floats arg'        `thenUs` \ floats' ->
 298          returnUs (floats', Var v)
 299
 300 -- version that doesn't consider an scc annotation to be trivial.
 301 exprIsTrivial (Var v)                  = True
 302 exprIsTrivial (Type _)                 = True
 303 exprIsTrivial (Lit lit)                = True
 304 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 305 exprIsTrivial (Note (SCC _) e)         = False
 306 exprIsTrivial (Note _ e)               = exprIsTrivial e
 307 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 308 exprIsTrivial other                    = False
 309
 310 -- ---------------------------------------------------------------------------
 311 -- Dealing with expressions
 312 -- ---------------------------------------------------------------------------
 313
 314 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
 315 corePrepAnExpr env expr
 316   = corePrepExprFloat env expr          `thenUs` \ (floats, expr) ->
 317     mkBinds floats expr
 318
 319
 320 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 321 -- If
 322 --      e  ===>  (bs, e')
 323 -- then
 324 --      e = let bs in e'        (semantically, that is!)
 325 --
 326 -- For example
 327 --      f (g x)   ===>   ([v = g x], f v)
 328
 329 corePrepExprFloat env (Var v)
 330   = fiddleCCall v                               `thenUs` \ v1 ->
 331     let v2 = lookupVarEnv env v1 `orElse` v1 in
 332     maybeSaturate v2 (Var v2) 0 (idType v2)     `thenUs` \ app ->
 333     returnUs (nilOL, app)
 334
 335 corePrepExprFloat env expr@(Type _)
 336   = returnUs (nilOL, expr)
 337
 338 corePrepExprFloat env expr@(Lit lit)
 339   = returnUs (nilOL, expr)
 340
 341 corePrepExprFloat env (Let bind body)
 342   = corePrepBind env bind               `thenUs` \ (env', new_binds) ->
 343     corePrepExprFloat env' body         `thenUs` \ (floats, new_body) ->
 344     returnUs (new_binds `appOL` floats, new_body)
 345
 346 corePrepExprFloat env (Note n@(SCC _) expr)
 347   = corePrepAnExpr env expr             `thenUs` \ expr1 ->
 348     deLam expr1                         `thenUs` \ expr2 ->
 349     returnUs (nilOL, Note n expr2)
 350
 351 corePrepExprFloat env (Note other_note expr)
 352   = corePrepExprFloat env expr          `thenUs` \ (floats, expr') ->
 353     returnUs (floats, Note other_note expr')
 354
 355 corePrepExprFloat env expr@(Lam _ _)
 356   = cloneBndrs env bndrs                `thenUs` \ (env', bndrs') ->
 357     corePrepAnExpr env' body            `thenUs` \ body' ->
 358     returnUs (nilOL, mkLams bndrs' body')
 359   where
 360     (bndrs,body) = collectBinders expr
 361
 362 corePrepExprFloat env (Case scrut bndr alts)
 363   = corePrepExprFloat env scrut         `thenUs` \ (floats, scrut') ->
 364     cloneBndr env bndr                  `thenUs` \ (env', bndr') ->
 365     mapUs (sat_alt env') alts           `thenUs` \ alts' ->
 366     returnUs (floats, mkCase scrut' bndr' alts')
 367   where
 368     sat_alt env (con, bs, rhs)
 369           = cloneBndrs env bs           `thenUs` \ (env', bs') ->
 370             corePrepAnExpr env' rhs     `thenUs` \ rhs1 ->
 371             deLam rhs1                  `thenUs` \ rhs2 ->
 372             returnUs (con, bs', rhs2)
 373
 374 corePrepExprFloat env expr@(App _ _)
 375   = collect_args expr 0  `thenUs` \ (app, (head,depth), ty, floats, ss) ->
 376     ASSERT(null ss)     -- make sure we used all the strictness info
 377
 378         -- Now deal with the function
 379     case head of
 380       Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
 381                    returnUs (floats, app')
 382
 383       _other    -> returnUs (floats, app)
 384
 385   where
 386
 387     -- Deconstruct and rebuild the application, floating any non-atomic
 388     -- arguments to the outside.  We collect the type of the expression,
 389     -- the head of the application, and the number of actual value arguments,
 390     -- all of which are used to possibly saturate this application if it
 391     -- has a constructor or primop at the head.
 392
 393     collect_args
 394         :: CoreExpr
 395         -> Int                            -- current app depth
 396         -> UniqSM (CoreExpr,              -- the rebuilt expression
 397                    (CoreExpr,Int),        -- the head of the application,
 398                                           -- and no. of args it was applied to
 399                    Type,                  -- type of the whole expr
 400                    OrdList FloatingBind,  -- any floats we pulled out
 401                    [Demand])              -- remaining argument demands
 402
 403     collect_args (App fun arg@(Type arg_ty)) depth
 404         = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 405           returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 406
 407     collect_args (App fun arg) depth
 408         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 409           let
 410               (ss1, ss_rest)   = case ss of
 411                                    (ss1:ss_rest) -> (ss1,     ss_rest)
 412                                    []            -> (lazyDmd, [])
 413               (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
 414                                  splitFunTy_maybe fun_ty
 415           in
 416           corePrepArg env arg (mkDemTy ss1 arg_ty)      `thenUs` \ (fs, arg') ->
 417           returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
 418
 419     collect_args (Var v) depth
 420         = fiddleCCall v `thenUs` \ v1 ->
 421           let v2 = lookupVarEnv env v1 `orElse` v1 in
 422           returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
 423         where
 424           stricts = case idNewStrictness v of
 425                         StrictSig (DmdType _ demands _)
 426                             | listLengthCmp demands depth /= GT -> demands
 427                                     -- length demands <= depth
 428                             | otherwise                         -> []
 429                 -- If depth < length demands, then we have too few args to
 430                 -- satisfy strictness  info so we have to  ignore all the
 431                 -- strictness info, e.g. + (error "urk")
 432                 -- Here, we can't evaluate the arg strictly, because this
 433                 -- partial application might be seq'd
 434
 435
 436     collect_args (Note (Coerce ty1 ty2) fun) depth
 437         = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 438           returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 439
 440     collect_args (Note note fun) depth
 441         | ignore_note note
 442         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 443           returnUs (Note note fun', hd, fun_ty, floats, ss)
 444
 445         -- non-variable fun, better let-bind it
 446     collect_args fun depth
 447         = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
 448           newVar ty                                     `thenUs` \ fn_id ->
 449           mkLocalNonRec fn_id onceDem fun_floats fun'   `thenUs` \ floats ->
 450           returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
 451         where
 452           ty = exprType fun
 453
 454     ignore_note InlineCall = True
 455     ignore_note InlineMe   = True
 456     ignore_note _other     = False
 457         -- we don't ignore SCCs, since they require some code generation
 458
 459 ------------------------------------------------------------------------------
 460 -- Building the saturated syntax
 461 -- ---------------------------------------------------------------------------
 462
 463 -- maybeSaturate deals with saturating primops and constructors
 464 -- The type is the type of the entire application
 465 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 466 maybeSaturate fn expr n_args ty
 467   | hasNoBinding fn = saturate_it
 468   | otherwise       = returnUs expr
 469   where
 470     fn_arity     = idArity fn
 471     excess_arity = fn_arity - n_args
 472     saturate_it  = getUniquesUs                 `thenUs` \ us ->
 473                    returnUs (etaExpand excess_arity us expr ty)
 474
 475 -- ---------------------------------------------------------------------------
 476 -- Precipitating the floating bindings
 477 -- ---------------------------------------------------------------------------
 478
 479 floatRhs :: TopLevelFlag -> RecFlag
 480          -> Id
 481          -> (OrdList FloatingBind, CoreExpr)    -- Rhs: let binds in body
 482          -> UniqSM (OrdList FloatingBind,       -- Floats out of this bind
 483                     CoreExpr)                   -- Final Rhs
 484
 485 floatRhs top_lvl is_rec bndr (floats, rhs)
 486   | isTopLevel top_lvl || exprIsValue rhs,      -- Float to expose value or
 487     allLazy top_lvl is_rec floats               -- at top level
 488   =     -- Why the test for allLazy?
 489         --      v = f (x `divInt#` y)
 490         -- we don't want to float the case, even if f has arity 2,
 491         -- because floating the case would make it evaluated too early
 492         --
 493         -- Finally, eta-expand the RHS, for the benefit of the code gen
 494     returnUs (floats, rhs)
 495
 496   | otherwise
 497         -- Don't float; the RHS isn't a value
 498   = mkBinds floats rhs          `thenUs` \ rhs' ->
 499     returnUs (nilOL, rhs')
 500
 501 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
 502 mkLocalNonRec :: Id  -> RhsDemand                       -- Lhs: id with demand
 503               -> OrdList FloatingBind -> CoreExpr       -- Rhs: let binds in body
 504               -> UniqSM (OrdList FloatingBind)
 505
 506 mkLocalNonRec bndr dem floats rhs
 507   | isUnLiftedType (idType bndr)
 508         -- If this is an unlifted binding, we always make a case for it.
 509   = ASSERT( not (isUnboxedTupleType (idType bndr)) )
 510     let
 511         float = FloatCase bndr rhs (exprOkForSpeculation rhs)
 512     in
 513     returnUs (floats `snocOL` float)
 514
 515   | isStrict dem
 516         -- It's a strict let so we definitely float all the bindings
 517  = let          -- Don't make a case for a value binding,
 518                 -- even if it's strict.  Otherwise we get
 519                 --      case (\x -> e) of ...!
 520         float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
 521               | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
 522     in
 523     returnUs (floats `snocOL` float)
 524
 525   | otherwise
 526   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)        `thenUs` \ (floats', rhs') ->
 527     returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
 528
 529   where
 530     bndr_ty      = idType bndr
 531     bndr_rep_ty  = repType bndr_ty
 532
 533 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 534 mkBinds binds body
 535   | isNilOL binds = returnUs body
 536   | otherwise     = deLam body          `thenUs` \ body' ->
 537                     returnUs (foldrOL mk_bind body' binds)
 538   where
 539     mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
 540     mk_bind (FloatLet bind)        body = Let bind body
 541
 542 etaExpandRhs bndr rhs
 543   =     -- Eta expand to match the arity claimed by the binder
 544         -- Remember, after CorePrep we must not change arity
 545         --
 546         -- Eta expansion might not have happened already,
 547         -- because it is done by the simplifier only when
 548         -- there at least one lambda already.
 549         --
 550         -- NB1:we could refrain when the RHS is trivial (which can happen
 551         --     for exported things).  This would reduce the amount of code
 552         --     generated (a little) and make things a little words for
 553         --     code compiled without -O.  The case in point is data constructor
 554         --     wrappers.
 555         --
 556         -- NB2: we have to be careful that the result of etaExpand doesn't
 557         --    invalidate any of the assumptions that CorePrep is attempting
 558         --    to establish.  One possible cause is eta expanding inside of
 559         --    an SCC note - we're now careful in etaExpand to make sure the
 560         --    SCC is pushed inside any new lambdas that are generated.
 561         --
 562         -- NB3: It's important to do eta expansion, and *then* ANF-ising
 563         --              f = /\a -> g (h 3)      -- h has arity 2
 564         -- If we ANF first we get
 565         --              f = /\a -> let s = h 3 in g s
 566         -- and now eta expansion gives
 567         --              f = /\a -> \ y -> (let s = h 3 in g s) y
 568         -- which is horrible.
 569         -- Eta expanding first gives
 570         --              f = /\a -> \y -> let s = h 3 in g s y
 571         --
 572     getUniquesUs                `thenUs` \ us ->
 573     returnUs (etaExpand arity us rhs (idType bndr))
 574   where
 575         -- For a GlobalId, take the Arity from the Id.
 576         -- It was set in CoreTidy and must not change
 577         -- For all others, just expand at will
 578     arity | isGlobalId bndr = idArity bndr
 579           | otherwise       = exprArity rhs
 580
 581 -- ---------------------------------------------------------------------------
 582 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 583 -- We arrange that they only show up as the RHS of a let(rec)
 584 -- ---------------------------------------------------------------------------
 585
 586 deLam :: CoreExpr -> UniqSM CoreExpr
 587 -- Remove top level lambdas by let-bindinig
 588
 589 deLam (Note n expr)
 590   =     -- You can get things like
 591         --      case e of { p -> coerce t (\s -> ...) }
 592     deLam expr  `thenUs` \ expr' ->
 593     returnUs (Note n expr')
 594
 595 deLam expr
 596   | null bndrs = returnUs expr
 597   | otherwise
 598   = case tryEta bndrs body of
 599       Just no_lam_result -> returnUs no_lam_result
 600       Nothing            -> newVar (exprType expr)      `thenUs` \ fn ->
 601                             returnUs (Let (NonRec fn expr) (Var fn))
 602   where
 603     (bndrs,body) = collectBinders expr
 604
 605 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 606 -- But the simplifier only eta reduces if that leaves something
 607 -- trivial (like f, or f Int).  But for deLam it would be enough to
 608 -- get to a partial application, like (map f).
 609
 610 tryEta bndrs expr@(App _ _)
 611   | ok_to_eta_reduce f &&
 612     n_remaining >= 0 &&
 613     and (zipWith ok bndrs last_args) &&
 614     not (any (`elemVarSet` fvs_remaining) bndrs)
 615   = Just remaining_expr
 616   where
 617     (f, args) = collectArgs expr
 618     remaining_expr = mkApps f remaining_args
 619     fvs_remaining = exprFreeVars remaining_expr
 620     (remaining_args, last_args) = splitAt n_remaining args
 621     n_remaining = length args - length bndrs
 622
 623     ok bndr (Var arg) = bndr == arg
 624     ok bndr other           = False
 625
 626           -- we can't eta reduce something which must be saturated.
 627     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 628     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 629
 630 tryEta bndrs (Let bind@(NonRec b r) body)
 631   | not (any (`elemVarSet` fvs) bndrs)
 632   = case tryEta bndrs body of
 633         Just e -> Just (Let bind e)
 634         Nothing -> Nothing
 635   where
 636     fvs = exprFreeVars r
 637
 638 tryEta bndrs _ = Nothing
 639 \end{code}
 640
 641
 642 -- -----------------------------------------------------------------------------
 643 --      Do the seq and par transformation
 644 -- -----------------------------------------------------------------------------
 645
 646 Here we do two pre-codegen transformations:
 647
 648 1.      case seq# a of {
 649           0       -> seqError ...
 650           DEFAULT -> rhs }
 651   ==>
 652         case a of { DEFAULT -> rhs }
 653
 654
 655 2.      case par# a of {
 656           0       -> parError ...
 657           DEFAULT -> rhs }
 658   ==>
 659         case par# a of {
 660           DEFAULT -> rhs }
 661
 662 NB:     seq# :: a -> Int#       -- Evaluate value and return anything
 663         par# :: a -> Int#       -- Spark value and return anything
 664
 665 These transformations can't be done earlier, or else we might
 666 think that the expression was strict in the variables in which
 667 rhs is strict --- but that would defeat the purpose of seq and par.
 668
 669
 670 \begin{code}
 671 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
 672                         -- DEFAULT alt is always first
 673   = case isPrimOpId_maybe fn of
 674         Just ParOp -> Case scrut bndr     [deflt_alt]
 675         Just SeqOp -> Case arg   new_bndr [deflt_alt]
 676         other      -> Case scrut bndr alts
 677   where
 678         -- The binder shouldn't be used in the expression!
 679     new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
 680                setIdType bndr (exprType arg)
 681         -- NB:  SeqOp :: forall a. a -> Int#
 682         -- So bndr has type Int#
 683         -- But now we are going to scrutinise the SeqOp's argument directly,
 684         -- so we must change the type of the case binder to match that
 685         -- of the argument expression e.
 686
 687 mkCase scrut bndr alts = Case scrut bndr alts
 688 \end{code}
 689
 690
 691 -- -----------------------------------------------------------------------------
 692 -- Demands
 693 -- -----------------------------------------------------------------------------
 694
 695 \begin{code}
 696 data RhsDemand
 697      = RhsDemand { isStrict :: Bool,  -- True => used at least once
 698                    isOnceDem   :: Bool   -- True => used at most once
 699                  }
 700
 701 mkDem :: Demand -> Bool -> RhsDemand
 702 mkDem strict once = RhsDemand (isStrictDmd strict) once
 703
 704 mkDemTy :: Demand -> Type -> RhsDemand
 705 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
 706
 707 isOnceTy :: Type -> Bool
 708 isOnceTy ty
 709   =
 710 #ifdef USMANY
 711     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 712 #endif
 713     once
 714   where
 715     u = uaUTy ty
 716     once | u `eqUsage` usOnce  = True
 717          | u `eqUsage` usMany  = False
 718          | isTyVarTy u         = False  -- if unknown at compile-time, is Top ie usMany
 719
 720 bdrDem :: Id -> RhsDemand
 721 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
 722
 723 safeDem, onceDem :: RhsDemand
 724 safeDem = RhsDemand False False  -- always safe to use this
 725 onceDem = RhsDemand False True   -- used at most once
 726 \end{code}
 727
 728
 729
 730
 731 %************************************************************************
 732 %*                                                                      *
 733 \subsection{Cloning}
 734 %*                                                                      *
 735 %************************************************************************
 736
 737 \begin{code}
 738 ------------------------------------------------------------------------------
 739 -- Cloning binders
 740 -- ---------------------------------------------------------------------------
 741
 742 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
 743 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 744
 745 cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
 746 cloneBndr env bndr
 747   | isLocalId bndr
 748   = getUniqueUs   `thenUs` \ uniq ->
 749     let
 750         bndr' = setVarUnique bndr uniq
 751     in
 752     returnUs (extendVarEnv env bndr bndr', bndr')
 753
 754   | otherwise   -- Top level things, which we don't want
 755                 -- to clone, have become GlobalIds by now
 756                 -- And we don't clone tyvars
 757   = returnUs (env, bndr)
 758
 759
 760 ------------------------------------------------------------------------------
 761 -- Cloning ccall Ids; each must have a unique name,
 762 -- to give the code generator a handle to hang it on
 763 -- ---------------------------------------------------------------------------
 764
 765 fiddleCCall :: Id -> UniqSM Id
 766 fiddleCCall id
 767   | isFCallId id = getUniqueUs          `thenUs` \ uniq ->
 768                    returnUs (id `setVarUnique` uniq)
 769   | otherwise    = returnUs id
 770
 771 ------------------------------------------------------------------------------
 772 -- Generating new binders
 773 -- ---------------------------------------------------------------------------
 774
 775 newVar :: Type -> UniqSM Id
 776 newVar ty
 777  = seqType ty                   `seq`
 778    getUniqueUs                  `thenUs` \ uniq ->
 779    returnUs (mkSysLocal SLIT("sat") uniq ty)
 780 \end{code}