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