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