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