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