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