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