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   = corePrepExprFloat env rhs                           `thenUs` \ (floats, rhs') ->
 174     cloneBndr env bndr                                  `thenUs` \ (env', bndr') ->
 175     mkLocalNonRec bndr' (bdrDem bndr') floats rhs'      `thenUs` \ floats' ->
 176     returnUs (env', floats')
 177
 178 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
 179
 180 --------------------------------
 181 corePrepRecPairs :: TopLevelFlag -> CloneEnv
 182                  -> [(Id,CoreExpr)]     -- Recursive bindings
 183                  -> UniqSM (CloneEnv, OrdList FloatingBind)
 184 -- Used for all recursive bindings, top level and otherwise
 185 corePrepRecPairs lvl env pairs
 186   = cloneBndrs env (map fst pairs)                              `thenUs` \ (env', bndrs') ->
 187     mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs        `thenUs` \ (floats_s, rhss') ->
 188     returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
 189   where
 190         -- Flatten all the floats, and the currrent
 191         -- group into a single giant Rec
 192     flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
 193
 194     get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
 195     get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
 196
 197 --------------------------------
 198 corePrepRhs :: TopLevelFlag -> RecFlag
 199             -> CloneEnv -> (Id, CoreExpr)
 200             -> UniqSM (OrdList FloatingBind, CoreExpr)
 201 -- Used for top-level bindings, and local recursive bindings
 202 corePrepRhs top_lvl is_rec env (bndr, rhs)
 203   = corePrepExprFloat env rhs           `thenUs` \ floats_w_rhs ->
 204     floatRhs top_lvl is_rec bndr floats_w_rhs
 205
 206
 207 -- ---------------------------------------------------------------------------
 208 -- Making arguments atomic (function args & constructor args)
 209 -- ---------------------------------------------------------------------------
 210
 211 -- This is where we arrange that a non-trivial argument is let-bound
 212 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
 213            -> UniqSM (OrdList FloatingBind, CoreArg)
 214 corePrepArg env arg dem
 215   = corePrepExprFloat env arg           `thenUs` \ (floats, arg') ->
 216     if no_binding_needed arg'
 217     then returnUs (floats, arg')
 218     else newVar (exprType arg') (exprArity arg')        `thenUs` \ v ->
 219          mkLocalNonRec v dem floats arg'                `thenUs` \ floats' ->
 220          returnUs (floats', Var v)
 221
 222 no_binding_needed | opt_RuntimeTypes = exprIsAtom
 223                   | otherwise        = exprIsTrivial
 224
 225 -- version that doesn't consider an scc annotation to be trivial.
 226 exprIsTrivial (Var v)
 227   | hasNoBinding v                     = idArity v == 0
 228   | otherwise                          = True
 229 exprIsTrivial (Type _)                 = True
 230 exprIsTrivial (Lit lit)                = True
 231 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 232 exprIsTrivial (Note (SCC _) e)         = False
 233 exprIsTrivial (Note _ e)               = exprIsTrivial e
 234 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 235 exprIsTrivial other                    = False
 236
 237 -- ---------------------------------------------------------------------------
 238 -- Dealing with expressions
 239 -- ---------------------------------------------------------------------------
 240
 241 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
 242 corePrepAnExpr env expr
 243   = corePrepExprFloat env expr          `thenUs` \ (floats, expr) ->
 244     mkBinds floats expr
 245
 246
 247 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 248 -- If
 249 --      e  ===>  (bs, e')
 250 -- then
 251 --      e = let bs in e'        (semantically, that is!)
 252 --
 253 -- For example
 254 --      f (g x)   ===>   ([v = g x], f v)
 255
 256 corePrepExprFloat env (Var v)
 257   = fiddleCCall v                               `thenUs` \ v1 ->
 258     let v2 = lookupVarEnv env v1 `orElse` v1 in
 259     maybeSaturate v2 (Var v2) 0 (idType v2)     `thenUs` \ app ->
 260     returnUs (nilOL, app)
 261
 262 corePrepExprFloat env expr@(Type _)
 263   = returnUs (nilOL, expr)
 264
 265 corePrepExprFloat env expr@(Lit lit)
 266   = returnUs (nilOL, expr)
 267
 268 corePrepExprFloat env (Let bind body)
 269   = corePrepBind env bind               `thenUs` \ (env', new_binds) ->
 270     corePrepExprFloat env' body         `thenUs` \ (floats, new_body) ->
 271     returnUs (new_binds `appOL` floats, new_body)
 272
 273 corePrepExprFloat env (Note n@(SCC _) expr)
 274   = corePrepAnExpr env expr             `thenUs` \ expr1 ->
 275     deLam expr1                         `thenUs` \ expr2 ->
 276     returnUs (nilOL, Note n expr2)
 277
 278 corePrepExprFloat env (Note other_note expr)
 279   = corePrepExprFloat env expr          `thenUs` \ (floats, expr') ->
 280     returnUs (floats, Note other_note expr')
 281
 282 corePrepExprFloat env expr@(Lam _ _)
 283   = corePrepAnExpr env body             `thenUs` \ body' ->
 284     returnUs (nilOL, mkLams bndrs body')
 285   where
 286     (bndrs,body) = collectBinders expr
 287
 288 corePrepExprFloat env (Case scrut bndr alts)
 289   = corePrepExprFloat env scrut         `thenUs` \ (floats, scrut') ->
 290     cloneBndr env bndr                  `thenUs` \ (env', bndr') ->
 291     mapUs (sat_alt env') alts           `thenUs` \ alts' ->
 292     returnUs (floats, mkCase scrut' bndr' alts')
 293   where
 294     sat_alt env (con, bs, rhs)
 295           = cloneBndrs env bs           `thenUs` \ (env', bs') ->
 296             corePrepAnExpr env' rhs     `thenUs` \ rhs1 ->
 297             deLam rhs1                  `thenUs` \ rhs2 ->
 298             returnUs (con, bs', rhs2)
 299
 300 corePrepExprFloat env expr@(App _ _)
 301   = collect_args expr 0  `thenUs` \ (app, (head,depth), ty, floats, ss) ->
 302     ASSERT(null ss)     -- make sure we used all the strictness info
 303
 304         -- Now deal with the function
 305     case head of
 306       Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
 307                    returnUs (floats, app')
 308
 309       _other    -> returnUs (floats, app)
 310
 311   where
 312
 313     -- Deconstruct and rebuild the application, floating any non-atomic
 314     -- arguments to the outside.  We collect the type of the expression,
 315     -- the head of the application, and the number of actual value arguments,
 316     -- all of which are used to possibly saturate this application if it
 317     -- has a constructor or primop at the head.
 318
 319     collect_args
 320         :: CoreExpr
 321         -> Int                            -- current app depth
 322         -> UniqSM (CoreExpr,              -- the rebuilt expression
 323                    (CoreExpr,Int),        -- the head of the application,
 324                                           -- and no. of args it was applied to
 325                    Type,                  -- type of the whole expr
 326                    OrdList FloatingBind,  -- any floats we pulled out
 327                    [Demand])              -- remaining argument demands
 328
 329     collect_args (App fun arg@(Type arg_ty)) depth
 330         = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 331           returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 332
 333     collect_args (App fun arg) depth
 334         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 335           let
 336               (ss1, ss_rest)   = case ss of
 337                                    (ss1:ss_rest) -> (ss1,     ss_rest)
 338                                    []            -> (lazyDmd, [])
 339               (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
 340                                  splitFunTy_maybe fun_ty
 341           in
 342           corePrepArg env arg (mkDemTy ss1 arg_ty)      `thenUs` \ (fs, arg') ->
 343           returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
 344
 345     collect_args (Var v) depth
 346         = fiddleCCall v `thenUs` \ v1 ->
 347           let v2 = lookupVarEnv env v1 `orElse` v1 in
 348           returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
 349         where
 350           stricts = case idNewStrictness v of
 351                         StrictSig (DmdType _ demands _)
 352                             | depth >= length demands -> demands
 353                             | otherwise               -> []
 354                 -- If depth < length demands, then we have too few args to
 355                 -- satisfy strictness  info so we have to  ignore all the
 356                 -- strictness info, e.g. + (error "urk")
 357                 -- Here, we can't evaluate the arg strictly, because this
 358                 -- partial application might be seq'd
 359
 360
 361     collect_args (Note (Coerce ty1 ty2) fun) depth
 362         = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 363           returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 364
 365     collect_args (Note note fun) depth
 366         | ignore_note note
 367         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 368           returnUs (Note note fun', hd, fun_ty, floats, ss)
 369
 370         -- non-variable fun, better let-bind it
 371     collect_args fun depth
 372         = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
 373           newVar ty (exprArity fun')                    `thenUs` \ fn_id ->
 374           mkLocalNonRec fn_id onceDem fun_floats fun'   `thenUs` \ floats ->
 375           returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
 376         where
 377           ty = exprType fun
 378
 379     ignore_note InlineCall = True
 380     ignore_note InlineMe   = True
 381     ignore_note _other     = False
 382         -- we don't ignore SCCs, since they require some code generation
 383
 384 ------------------------------------------------------------------------------
 385 -- Building the saturated syntax
 386 -- ---------------------------------------------------------------------------
 387
 388 -- maybeSaturate deals with saturating primops and constructors
 389 -- The type is the type of the entire application
 390 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 391 maybeSaturate fn expr n_args ty
 392   | hasNoBinding fn = saturate_it
 393   | otherwise       = returnUs expr
 394   where
 395     fn_arity     = idArity fn
 396     excess_arity = fn_arity - n_args
 397     saturate_it  = getUniquesUs                 `thenUs` \ us ->
 398                    returnUs (etaExpand excess_arity us expr ty)
 399
 400 -- ---------------------------------------------------------------------------
 401 -- Precipitating the floating bindings
 402 -- ---------------------------------------------------------------------------
 403
 404 floatRhs :: TopLevelFlag -> RecFlag
 405          -> Id
 406          -> (OrdList FloatingBind, CoreExpr)    -- Rhs: let binds in body
 407          -> UniqSM (OrdList FloatingBind,       -- Floats out of this bind
 408                     CoreExpr)                   -- Final Rhs
 409
 410 floatRhs top_lvl is_rec bndr (floats, rhs)
 411   | isTopLevel top_lvl || exprIsValue rhs,      -- Float to expose value or
 412     allLazy top_lvl is_rec floats               -- at top level
 413   =     -- Why the test for allLazy?
 414         --      v = f (x `divInt#` y)
 415         -- we don't want to float the case, even if f has arity 2,
 416         -- because floating the case would make it evaluated too early
 417         --
 418         -- Finally, eta-expand the RHS, for the benefit of the code gen
 419     etaExpandRhs bndr rhs       `thenUs` \ rhs' ->
 420     returnUs (floats, rhs')
 421
 422   | otherwise
 423         -- Don't float; the RHS isn't a value
 424   = mkBinds floats rhs          `thenUs` \ rhs' ->
 425     etaExpandRhs bndr rhs'      `thenUs` \ rhs'' ->
 426     returnUs (nilOL, rhs'')
 427
 428 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
 429 mkLocalNonRec :: Id  -> RhsDemand                       -- Lhs: id with demand
 430               -> OrdList FloatingBind -> CoreExpr       -- Rhs: let binds in body
 431               -> UniqSM (OrdList FloatingBind)
 432
 433 mkLocalNonRec bndr dem floats rhs
 434   |  isUnLiftedType (idType bndr) || isStrict dem
 435         -- It's a strict let, or the binder is unlifted,
 436         -- so we definitely float all the bindings
 437   = ASSERT( not (isUnboxedTupleType (idType bndr)) )
 438     let         -- Don't make a case for a value binding,
 439                 -- even if it's strict.  Otherwise we get
 440                 --      case (\x -> e) of ...!
 441         float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
 442               | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
 443     in
 444     returnUs (floats `snocOL` float)
 445
 446   | otherwise
 447   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)        `thenUs` \ (floats', rhs') ->
 448     returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
 449
 450 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 451 mkBinds binds body
 452   | isNilOL binds = returnUs body
 453   | otherwise     = deLam body          `thenUs` \ body' ->
 454                     returnUs (foldrOL mk_bind body' binds)
 455   where
 456     mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
 457     mk_bind (FloatLet bind)        body = Let bind body
 458
 459 etaExpandRhs bndr rhs
 460   =     -- Eta expand to match the arity claimed by the binder
 461         -- Remember, after CorePrep we must not change arity
 462         --
 463         -- Eta expansion might not have happened already,
 464         -- because it is done by the simplifier only when
 465         -- there at least one lambda already.
 466         --
 467         -- NB1:we could refrain when the RHS is trivial (which can happen
 468         --     for exported things).  This would reduce the amount of code
 469         --     generated (a little) and make things a little words for
 470         --     code compiled without -O.  The case in point is data constructor
 471         --     wrappers.
 472         --
 473         -- NB2: we have to be careful that the result of etaExpand doesn't
 474         --    invalidate any of the assumptions that CorePrep is attempting
 475         --    to establish.  One possible cause is eta expanding inside of
 476         --    an SCC note - we're now careful in etaExpand to make sure the
 477         --    SCC is pushed inside any new lambdas that are generated.
 478         --
 479     getUniquesUs                `thenUs` \ us ->
 480     returnUs (etaExpand (idArity bndr) us rhs (idType bndr))
 481
 482 -- ---------------------------------------------------------------------------
 483 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 484 -- We arrange that they only show up as the RHS of a let(rec)
 485 -- ---------------------------------------------------------------------------
 486
 487 deLam :: CoreExpr -> UniqSM CoreExpr
 488 -- Remove top level lambdas by let-bindinig
 489
 490 deLam (Note n expr)
 491   =     -- You can get things like
 492         --      case e of { p -> coerce t (\s -> ...) }
 493     deLam expr  `thenUs` \ expr' ->
 494     returnUs (Note n expr')
 495
 496 deLam expr
 497   | null bndrs = returnUs expr
 498   | otherwise
 499   = case tryEta bndrs body of
 500       Just no_lam_result -> returnUs no_lam_result
 501       Nothing            -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn ->
 502                             returnUs (Let (NonRec fn expr) (Var fn))
 503   where
 504     (bndrs,body) = collectBinders expr
 505
 506 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 507 -- But the simplifier only eta reduces if that leaves something
 508 -- trivial (like f, or f Int).  But for deLam it would be enough to
 509 -- get to a partial application, like (map f).
 510
 511 tryEta bndrs expr@(App _ _)
 512   | ok_to_eta_reduce f &&
 513     n_remaining >= 0 &&
 514     and (zipWith ok bndrs last_args) &&
 515     not (any (`elemVarSet` fvs_remaining) bndrs)
 516   = Just remaining_expr
 517   where
 518     (f, args) = collectArgs expr
 519     remaining_expr = mkApps f remaining_args
 520     fvs_remaining = exprFreeVars remaining_expr
 521     (remaining_args, last_args) = splitAt n_remaining args
 522     n_remaining = length args - length bndrs
 523
 524     ok bndr (Var arg) = bndr == arg
 525     ok bndr other           = False
 526
 527           -- we can't eta reduce something which must be saturated.
 528     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 529     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 530
 531 tryEta bndrs (Let bind@(NonRec b r) body)
 532   | not (any (`elemVarSet` fvs) bndrs)
 533   = case tryEta bndrs body of
 534         Just e -> Just (Let bind e)
 535         Nothing -> Nothing
 536   where
 537     fvs = exprFreeVars r
 538
 539 tryEta bndrs _ = Nothing
 540 \end{code}
 541
 542
 543 -- -----------------------------------------------------------------------------
 544 --      Do the seq and par transformation
 545 -- -----------------------------------------------------------------------------
 546
 547 Here we do two pre-codegen transformations:
 548
 549 1.      case seq# a of {
 550           0       -> seqError ...
 551           DEFAULT -> rhs }
 552   ==>
 553         case a of { DEFAULT -> rhs }
 554
 555
 556 2.      case par# a of {
 557           0       -> parError ...
 558           DEFAULT -> rhs }
 559   ==>
 560         case par# a of {
 561           DEFAULT -> rhs }
 562
 563 NB:     seq# :: a -> Int#       -- Evaluate value and return anything
 564         par# :: a -> Int#       -- Spark value and return anything
 565
 566 These transformations can't be done earlier, or else we might
 567 think that the expression was strict in the variables in which
 568 rhs is strict --- but that would defeat the purpose of seq and par.
 569
 570
 571 \begin{code}
 572 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
 573                         -- DEFAULT alt is always first
 574   = case isPrimOpId_maybe fn of
 575         Just ParOp -> Case scrut bndr     [deflt_alt]
 576         Just SeqOp -> Case arg   new_bndr [deflt_alt]
 577         other      -> Case scrut bndr alts
 578   where
 579         -- The binder shouldn't be used in the expression!
 580     new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
 581                setIdType bndr (exprType arg)
 582         -- NB:  SeqOp :: forall a. a -> Int#
 583         -- So bndr has type Int#
 584         -- But now we are going to scrutinise the SeqOp's argument directly,
 585         -- so we must change the type of the case binder to match that
 586         -- of the argument expression e.
 587
 588 mkCase scrut bndr alts = Case scrut bndr alts
 589 \end{code}
 590
 591
 592 -- -----------------------------------------------------------------------------
 593 -- Demands
 594 -- -----------------------------------------------------------------------------
 595
 596 \begin{code}
 597 data RhsDemand
 598      = RhsDemand { isStrict :: Bool,  -- True => used at least once
 599                    isOnceDem   :: Bool   -- True => used at most once
 600                  }
 601
 602 mkDem :: Demand -> Bool -> RhsDemand
 603 mkDem strict once = RhsDemand (isStrictDmd strict) once
 604
 605 mkDemTy :: Demand -> Type -> RhsDemand
 606 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
 607
 608 isOnceTy :: Type -> Bool
 609 isOnceTy ty
 610   =
 611 #ifdef USMANY
 612     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 613 #endif
 614     once
 615   where
 616     u = uaUTy ty
 617     once | u `eqUsage` usOnce  = True
 618          | u `eqUsage` usMany  = False
 619          | isTyVarTy u         = False  -- if unknown at compile-time, is Top ie usMany
 620
 621 bdrDem :: Id -> RhsDemand
 622 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
 623
 624 safeDem, onceDem :: RhsDemand
 625 safeDem = RhsDemand False False  -- always safe to use this
 626 onceDem = RhsDemand False True   -- used at most once
 627 \end{code}
 628
 629
 630
 631
 632 %************************************************************************
 633 %*                                                                      *
 634 \subsection{Cloning}
 635 %*                                                                      *
 636 %************************************************************************
 637
 638 \begin{code}
 639 ------------------------------------------------------------------------------
 640 -- Cloning binders
 641 -- ---------------------------------------------------------------------------
 642
 643 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
 644 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 645
 646 cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
 647 cloneBndr env bndr
 648   | isGlobalId bndr             -- Top level things, which we don't want
 649   = returnUs (env, bndr)        -- to clone, have become GlobalIds by now
 650
 651   | otherwise
 652   = getUniqueUs   `thenUs` \ uniq ->
 653     let
 654         bndr' = setVarUnique bndr uniq
 655     in
 656     returnUs (extendVarEnv env bndr bndr', bndr')
 657
 658 ------------------------------------------------------------------------------
 659 -- Cloning ccall Ids; each must have a unique name,
 660 -- to give the code generator a handle to hang it on
 661 -- ---------------------------------------------------------------------------
 662
 663 fiddleCCall :: Id -> UniqSM Id
 664 fiddleCCall id
 665   | isFCallId id = getUniqueUs          `thenUs` \ uniq ->
 666                    returnUs (id `setVarUnique` uniq)
 667   | otherwise    = returnUs id
 668
 669 ------------------------------------------------------------------------------
 670 -- Generating new binders
 671 -- ---------------------------------------------------------------------------
 672
 673 newVar :: Type -> Arity -> UniqSM Id
 674 -- We're creating a new let binder, and we must give
 675 -- it the right arity for the benefit of the code generator.
 676 newVar ty arity
 677  = seqType ty                   `seq`
 678    getUniqueUs                  `thenUs` \ uniq ->
 679    returnUs (mkSysLocal SLIT("sat") uniq ty
 680              `setIdArity` arity)
 681 \end{code}