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