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